Find the directory part (minus the filename) of a full path in access 97
For various reasons, I\'m stuck in Access 97 and need to get only the path part of a full pathname.
For example, the name
c:\\whatever dir\\another d
-
vFilename="C:\Informes\Indicadores\Program\Ind_Cont_PRv.txt"
vDirFile = Replace(vFilename, Dir(vFileName, vbDirectory), "")
' Result=C:\Informes\Indicadores_Contraloria\Programa\Versiones anteriores\
讨论(0) -
You can do something simple like:
Left(path, InStrRev(path, "\"))Example:
Function GetDirectory(path) GetDirectory = Left(path, InStrRev(path, Application.PathSeparator)) End Function讨论(0) -
If you are confident in your input parameters, you can use this single line of code which uses the native Split and Join functions and Excel native Application.pathSeparator.
Split(Join(Split(strPath, "."), Application.pathSeparator), Application.pathSeparator)If you want a more extensive function, the code below is tested in Windows and should also work on Mac (though not tested). Be sure to also copy the supporting function GetPathSeparator, or modify the code to use Application.pathSeparator. Note, this is a first draft; I should really refactor it to be more concise.
Private Sub ParsePath2Test() 'ParsePath2(DrivePathFileExt, -2) returns a multi-line string for debugging. Dim p As String, n As Integer Debug.Print String(2, vbCrLf) If True Then Debug.Print String(2, vbCrLf) Debug.Print ParsePath2("", -2) Debug.Print ParsePath2("C:", -2) Debug.Print ParsePath2("C:\", -2) Debug.Print ParsePath2("C:\Windows", -2) Debug.Print ParsePath2("C:\Windows\notepad.exe", -2) Debug.Print ParsePath2("C:\Windows\SysWOW64", -2) Debug.Print ParsePath2("C:\Windows\SysWOW64\", -2) Debug.Print ParsePath2("C:\Windows\SysWOW64\AcLayers.dll", -2) Debug.Print ParsePath2("C:\Windows\SysWOW64\.fakedir", -2) Debug.Print ParsePath2("C:\Windows\SysWOW64\fakefile.ext", -2) End If If True Then Debug.Print String(1, vbCrLf) Debug.Print ParsePath2("\Windows", -2) Debug.Print ParsePath2("\Windows\notepad.exe", -2) Debug.Print ParsePath2("\Windows\SysWOW64", -2) Debug.Print ParsePath2("\Windows\SysWOW64\", -2) Debug.Print ParsePath2("\Windows\SysWOW64\AcLayers.dll", -2) Debug.Print ParsePath2("\Windows\SysWOW64\.fakedir", -2) Debug.Print ParsePath2("\Windows\SysWOW64\fakefile.ext", -2) End If If True Then Debug.Print String(1, vbCrLf) Debug.Print ParsePath2("Windows\notepad.exe", -2) Debug.Print ParsePath2("Windows\SysWOW64", -2) Debug.Print ParsePath2("Windows\SysWOW64\", -2) Debug.Print ParsePath2("Windows\SysWOW64\AcLayers.dll", -2) Debug.Print ParsePath2("Windows\SysWOW64\.fakedir", -2) Debug.Print ParsePath2("Windows\SysWOW64\fakefile.ext", -2) Debug.Print ParsePath2(".fakedir", -2) Debug.Print ParsePath2("fakefile.txt", -2) Debug.Print ParsePath2("fakefile.onenote", -2) Debug.Print ParsePath2("C:\Personal\Workspace\Code\PythonVenvs\xlwings_test\.idea", -2) Debug.Print ParsePath2("Windows", -2) ' Expected to raise error 52 End If If True Then Debug.Print String(2, vbCrLf) Debug.Print "ParsePath2 ""\Windows\SysWOW64\fakefile.ext"" with different ReturnType values" Debug.Print , "{empty}", "D", ParsePath2("Windows\SysWOW64\fakefile.ext")(1) Debug.Print , "0", "D", ParsePath2("Windows\SysWOW64\fakefile.ext", 0)(1) Debug.Print , "1", "ext", ParsePath2("Windows\SysWOW64\fakefile.ext", 1) Debug.Print , "10", "file", ParsePath2("Windows\SysWOW64\fakefile.ext", 10) Debug.Print , "11", "file.ext", ParsePath2("Windows\SysWOW64\fakefile.ext", 11) Debug.Print , "100", "path", ParsePath2("Windows\SysWOW64\fakefile.ext", 100) Debug.Print , "110", "path\file", ParsePath2("Windows\SysWOW64\fakefile.ext", 110) Debug.Print , "111", "path\file.ext", ParsePath2("Windows\SysWOW64\fakefile.ext", 111) Debug.Print , "1000", "D", ParsePath2("Windows\SysWOW64\fakefile.ext", 1000) Debug.Print , "1100", "D:\path", ParsePath2("Windows\SysWOW64\fakefile.ext", 1100) Debug.Print , "1110", "D:\p\file", ParsePath2("Windows\SysWOW64\fakefile.ext", 1110) Debug.Print , "1111", "D:\p\f.ext", ParsePath2("Windows\SysWOW64\fakefile.ext", 1111) On Error GoTo EH: ' This is expected to presetn an error: p = "Windows\SysWOW64\fakefile.ext" n = 1010 Debug.Print "1010", "D:\p\file.ext", ParsePath2("Windows\SysWOW64\fakefile.ext", 1010) On Error GoTo 0 End If Exit Sub EH: Debug.Print , CStr(n), "Error: "; Err.Number, Err.Description Resume Next End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function ParsePath2(ByVal DrivePathFileExt As String _ , Optional ReturnType As Integer = 0) ' Writen by Chris Advena. You may modify and use this code provided you leave ' this credit in the code. ' Parses the input DrivePathFileExt string into individual components (drive ' letter, folders, filename and extension) and returns the portions you wish ' based on ReturnType. ' Returns either an array of strings (ReturnType = 0) or an individual string ' (all other defined ReturnType values). ' ' Parameters: ' DrivePathFileExt: The full drive letter, path, filename and extension ' ReturnType: -2 or a string up of to 4 ones with leading or lagging zeros ' (e.g., 0001) ' -2: special code for debugging use in ParsePath2Test(). ' Results in printing verbose information to the Immediate window. ' 0: default: Array(driveStr, pathStr, fileStr, extStr) ' 1: extension ' 10: filename stripped of extension ' 11: filename.extension, excluding drive and folders ' 100: folders, excluding drive letter filename and extension ' 111: folders\filename.extension, excluding drive letter ' 1000: drive leter only ' 1100: drive:\folders, excluding filename and extension ' 1110: drive:\folders\filename, excluding extension ' 1010, 0101, 1001: invalid ReturnTypes. Will result raise error 380, Value ' is not valid. Dim driveStr As String, pathStr As String Dim fileStr As String, extStr As String Dim drivePathStr As String Dim pathFileExtStr As String, fileExtStr As String Dim s As String, cnt As Integer Dim i As Integer, slashStr As String Dim dotLoc As Integer, slashLoc As Integer, colonLoc As Integer Dim extLen As Integer, fileLen As Integer, pathLen As Integer Dim errStr As String DrivePathFileExt = Trim(DrivePathFileExt) If DrivePathFileExt = "" Then fileStr = "" extStr = "" fileExtStr = "" pathStr = "" pathFileExtStr = "" drivePathStr = "" GoTo ReturnResults End If ' Determine if Dos(/) or UNIX(\) slash is used slashStr = GetPathSeparator(DrivePathFileExt) ' Find location of colon, rightmost slash and dot. ' COLON: colonLoc and driveStr colonLoc = 0 driveStr = "" If Mid(DrivePathFileExt, 2, 1) = ":" Then colonLoc = 2 driveStr = Left(DrivePathFileExt, 1) End If #If Mac Then pathFileExtStr = DrivePathFileExt #Else ' Windows pathFileExtStr = "" If Len(DrivePathFileExt) > colonLoc _ Then pathFileExtStr = Mid(DrivePathFileExt, colonLoc + 1) #End If ' SLASH: slashLoc, fileExtStr and fileStr ' Find the rightmost path separator (Win backslash or Mac Fwdslash). slashLoc = InStrRev(DrivePathFileExt, slashStr, -1, vbBinaryCompare) ' DOT: dotLoc and extStr ' Find rightmost dot. If that dot is not part of a relative reference, ' then set dotLoc. dotLoc is meant to apply to the dot before an extension, ' NOT relative path reference dots. REl ref dots appear as "." or ".." at ' the very leftmost of the path string. dotLoc = InStrRev(DrivePathFileExt, ".", -1, vbTextCompare) If Left(DrivePathFileExt, 1) = "." And dotLoc <= 2 Then dotLoc = 0 If slashLoc + 1 = dotLoc Then dotLoc = 0 If Len(extStr) = 0 And Right(pathFileExtStr, 1) <> slashStr _ Then pathFileExtStr = pathFileExtStr & slashStr End If #If Not Mac Then ' In windows, filenames cannot end with a dot ("."). If dotLoc = Len(DrivePathFileExt) Then s = "Error in FileManagementMod.ParsePath2 function. " _ & "DrivePathFileExt " & DrivePathFileExt _ & " cannot end iwth a dot ('.')." Err.Raise 52, "FileManagementMod.ParsePath2", s End If #End If ' extStr extStr = "" If dotLoc > 0 And (dotLoc < Len(DrivePathFileExt)) _ Then extStr = Mid(DrivePathFileExt, dotLoc + 1) ' fileExtStr fileExtStr = "" If slashLoc > 0 _ And slashLoc < Len(DrivePathFileExt) _ And dotLoc > slashLoc Then fileExtStr = Mid(DrivePathFileExt, slashLoc + 1) End If ' Validate the input: DrivePathFileExt s = "" #If Mac Then If InStr(1, DrivePathFileExt, ":") > 0 Then s = "DrivePathFileExt ('" & DrivePathFileExt _ & "')has invalid format. " _ & "UNIX/Mac filenames cannot contain a colon ('.')." End If #End If If Not colonLoc = 0 And slashLoc = 0 And dotLoc = 0 _ And Left(DrivePathFileExt, 1) <> slashStr _ And Left(DrivePathFileExt, 1) <> "." Then s = "DrivePathFileExt ('" & DrivePathFileExt _ & "') has invalid format. " _ & "Good example: 'C:\folder\file.txt'" ElseIf colonLoc <> 0 And colonLoc <> 2 Then ' We are on Windows and there is a colon; it can only be ' in position 2. s = "DrivePathFileExt ('" & DrivePathFileExt _ & "') has invalid format. " _ & "In the Windows operating system, " _ & "a colon (':') can only be the second character '" _ & "of a valid file path. " ElseIf Left(DrivePathFileExt, 1) = ":" _ Or InStr(3, DrivePathFileExt, ":", vbTextCompare) > 0 Then 'If path contains a drive letter, it must contain at least one slash. s = "DrivePathFileExt ('" & DrivePathFileExt _ & "') has invalid format. " _ & "Colon can only appear in the second character position." _ & slashStr & "')." ElseIf colonLoc > 0 And slashLoc = 0 _ And Len(DrivePathFileExt) > 2 Then 'If path contains a drive letter, it must contain at least one slash. s = "DrivePathFileExt ('" & DrivePathFileExt _ & "') has invalid format. " _ & "The last dot ('.') cannot be before the last file separator '" _ & slashStr & "')." ElseIf colonLoc = 2 _ And InStr(1, DrivePathFileExt, slashStr, vbTextCompare) = 0 _ And Len(DrivePathFileExt) > 2 Then ' There is a colon, but no file separator (slash). This is invalid. s = "DrivePathFileExt ('" & DrivePathFileExt _ & "') has invalid format. " _ & "If a drive letter is included, then there must be at " _ & "least one file separator character ('" & slashStr & "')." ElseIf Len(driveStr) > 0 And Len(DrivePathFileExt) > 2 And slashLoc = 0 Then ' If path contains a drive letter and is more than 2 character long ' (e.g., 'C:'), it must contain at least one slash. s = "DrivePathFileExt cannot contain a drive letter but no path separator." End If If Len(s) > 0 Then End If ' Determine if DrivePathFileExt = DrivePath ' or = Path (with no fileStr or extStr components). If Right(DrivePathFileExt, 1) = slashStr _ Or slashLoc = 0 _ Or dotLoc = 0 _ Or (dotLoc > 0 And dotLoc <= slashLoc + 1) Then ' If rightmost character is the slashStr, then no fileExt exists, just drivePath ' If no dot found, then no extension. Assume a folder is after the last slashstr, ' not a filename. ' If a dot is found (extension exists), ' If a rightmost dot appears one-char to the right of the rightmost slash ' or anywhere before (left) of that, it is not a file/ext separator. Exmaple: ' 'C:\folder1\.folder2' Then ' If no slashes, then no fileExt exists. It must just be a driveletter. ' DrivePathFileExt contains no file or ext name. fileStr = "" extStr = "" fileExtStr = "" pathStr = pathFileExtStr drivePathStr = DrivePathFileExt GoTo ReturnResults Else ' fileStr fileStr = "" If slashLoc > 0 Then If Len(extStr) = 0 Then fileStr = fileExtStr Else ' length of filename excluding dot and extension. i = Len(fileExtStr) - Len(extStr) - 1 fileStr = Left(fileExtStr, i) End If Else s = "Error in FileManagementMod.ParsePath2 function. " _ & "*** Unhandled scenario: find fileStr when slashLoc = 0. *** " Err.Raise 52, "FileManagementMod.ParsePath2", s End If ' pathStr pathStr = "" ' length of pathFileExtStr excluding fileExt. i = Len(pathFileExtStr) - Len(fileExtStr) pathStr = Left(pathFileExtStr, i) ' drivePathStr drivePathStr = "" ' length of DrivePathFileExt excluding dot and extension. i = Len(DrivePathFileExt) - Len(fileExtStr) drivePathStr = Left(DrivePathFileExt, i) End If ReturnResults: ' ReturnType uses a 4-digit binary code: dpfe = drive path file extension, ' where 1 = return in array and 0 = do not return in array ' -2, and 0 are special cases that do not follow the code. ' Note: pathstr is determined with the tailing slashstr If Len(drivePathStr) > 0 And Right(drivePathStr, 1) <> slashStr _ Then drivePathStr = drivePathStr & slashStr If Len(pathStr) > 0 And Right(pathStr, 1) <> slashStr _ Then pathStr = pathStr & slashStr #If Not Mac Then ' Including this code add a slash to the beginnning where missing. ' the downside is that it would create an absolute path where a ' sub-path of the current folder is intended. 'If colonLoc = 0 Then ' If Len(drivePathStr) > 0 And Not IsIn(Left(drivePathStr, 1), slashStr, ".") _ Then drivePathStr = slashStr & drivePathStr ' If Len(pathStr) > 0 And Not IsIn(Left(pathStr, 1), slashStr, ".") _ Then pathStr = slashStr & pathStr ' If Len(pathFileExtStr) > 0 And Not IsIn(Left(pathFileExtStr, 1), slashStr, ".") _ Then pathFileExtStr = slashStr & pathFileExtStr 'End If #End If Select Case ReturnType Case -2 ' used for ParsePath2Test() only. ParsePath2 = "DrivePathFileExt " _ & CStr(Nz(DrivePathFileExt, "{empty string}")) _ & vbCrLf & " " _ & "-------------- -----------------------------------------" _ & vbCrLf & " " & "D:\Path\ " & drivePathStr _ & vbCrLf & " " & "\path[\file.ext] " & pathFileExtStr _ & vbCrLf & " " & "\path\ " & pathStr _ & vbCrLf & " " & "file.ext " & fileExtStr _ & vbCrLf & " " & "file " & fileStr _ & vbCrLf & " " & "ext " & extStr _ & vbCrLf & " " & "D " & driveStr _ & vbCrLf & vbCrLf ' My custom debug printer prints to Immediate winodw and log file. ' Dbg.Prnt 2, ParsePath2 Debug.Print ParsePath2 Case 1 '0001: ext ParsePath2 = extStr Case 10 '0010: file ParsePath2 = fileStr Case 11 '0011: file.ext ParsePath2 = fileExtStr Case 100 '0100: path ParsePath2 = pathStr Case 110 '0110: (path, file) ParsePath2 = pathStr & fileStr Case 111 '0111: ParsePath2 = pathFileExtStr Case 1000 ParsePath2 = driveStr Case 1100 ParsePath2 = drivePathStr Case 1110 ParsePath2 = drivePathStr & fileStr Case 1111 ParsePath2 = DrivePathFileExt Case 1010, 101, 1001 s = "Error in FileManagementMod.ParsePath2 function. " _ & "Value of Paramter (ReturnType = " _ & CStr(ReturnType) & ") is not valid." Err.Raise 380, "FileManagementMod.ParsePath2", s Case Else ' default: 0 ParsePath2 = Array(driveStr, pathStr, fileStr, extStr) End Select End FunctionSupporting function GetPathSeparatorTest extends the native Application.pathSeparator (or bypasses when needed) to work on Mac and Win. It can also takes an optional path string and will try to determine the path separator used in the string (favoring the OS native path separator).
Private Sub GetPathSeparatorTest() Dim s As String Debug.Print "GetPathSeparator(s):" Debug.Print "s not provided: ", GetPathSeparator s = "C:\folder1\folder2\file.ext" Debug.Print "s = "; s, GetPathSeparator(DrivePathFileExt:=s) s = "C:/folder1/folder2/file.ext" Debug.Print "s = "; s, GetPathSeparator(DrivePathFileExt:=s) End Sub Function GetPathSeparator(Optional DrivePathFileExt As String = "") As String ' by Chris Advena ' Finds the path separator from a string, DrivePathFileExt. ' If DrivePathFileExt is not provided, return the operating system path separator ' (Windows = backslash, Mac = forwardslash). ' Mac/Win compatible. ' Initialize Dim retStr As String: retStr = "" Dim OSSlash As String: OSSlash = "" Dim OSOppositeSlash As String: OSOppositeSlash = "" Dim PathFileExtSlash As String GetPathSeparator = "" retStr = "" ' Determine if OS expects fwd or back slash ("/" or "\"). On Error GoTo EH OSSlash = Application.pathSeparator If DrivePathFileExt = "" Then ' Input parameter DrivePathFileExt is empty, so use OS file separator. retStr = OSSlash Else ' Input parameter DrivePathFileExt provided. See if it contains / or \. ' Set OSOppositeSlash to the opposite slash the OS expects. OSOppositeSlash = "\" If OSSlash = "\" Then OSOppositeSlash = "/" ' If DrivePathFileExt does NOT contain OSSlash ' and DOES contain OSOppositeSlash, return OSOppositeSlash. ' Otherwise, assume OSSlash is correct. retStr = OSSlash If InStr(1, DrivePathFileExt, OSSlash, vbTextCompare) = 0 _ And InStr(1, DrivePathFileExt, OSOppositeSlash, vbTextCompare) > 0 Then retStr = OSOppositeSlash End If End If GetPathSeparator = retStr Exit Function EH: ' Application.PathSeparator property does not exist in Access, ' so get it the slightly less easy way. #If Mac Then ' Application.PathSeparator doesn't seem to exist in Access... OSSlash = "/" #Else OSSlash = "\" #End If Resume Next End FunctionSupporting function (actually commented out, so you can skip this if you don't plan to use it).
Sub IsInTest() ' IsIn2 is case insensitive Dim StrToFind As String, arr As Variant arr = Array("Me", "You", "Dog", "Boo") StrToFind = "doG" Debug.Print "Is '" & CStr(StrToFind) & "' in list (expect True): " _ , IsIn(StrToFind, "Me", "You", "Dog", "Boo") StrToFind = "Porcupine" Debug.Print "Is '" & CStr(StrToFind) & "' in list (expect False): " _ , IsIn(StrToFind, "Me", "You", "Dog", "Boo") End Sub Function IsIn(ByVal StrToFind, ParamArray StringArgs() As Variant) As Boolean ' StrToFind: the string to find in the list of StringArgs() ' StringArgs: 1-dimensional array containing string values. ' Built for Strings, but actually works with other data types. Dim arr As Variant arr = StringArgs IsIn = Not IsError(Application.Match(StrToFind, arr, False)) End Function讨论(0) -
That's about it. There is no magic built-in function...
讨论(0)
加载中...
- 热议问题