出于各种原因，我被困在Access 97中，需要获取完整路径名的路径部分。
例如，名字
c:whatever diranother dirstuff.mdb
应该成为
c:whatever diranother dir
This site has some suggestions on how to do it: http://www.ammara.com/access_image_faq/parse_path_filename.html
但它们看起来相当丑陋。肯定有更好的方法吧？
你可以做一些简单的事情，比如：Left(path, InStrRev(path, ""))
例子:
Function GetDirectory(path)
GetDirectory = Left(path, InStrRev(path, Application.PathSeparator))
End Function
我总是使用 FileSystemObject 进行这种操作。这是我使用的一个小包装器函数。请确保引用了 Microsoft Scripting Runtime。
Function StripFilename(sPathFile As String) As String
given a full path and file, strip the filename off the end and return the path
Dim filesystem As New FileSystemObject
StripFilename = filesystem.GetParentFolderName(sPathFile) & ""
Exit Function
End Function
这似乎能够工作。上述方法在 Excel 2010 中无法使用。
Function StripFilename(sPathFile As String) As String
given a full path and file, strip the filename off the end and return the path
Dim filesystem As Object
Set filesystem = CreateObject("Scripting.FilesystemObject")
StripFilename = filesystem.GetParentFolderName(sPathFile) & ""
Exit Function
End Function
如果您只需要在Access UI中当前打开的MDB文件路径，我建议编写一个函数来解析CurrentDB.Name，然后将结果存储在函数内的静态变量中。类似于这样：
Public Function CurrentPath() As String
Dim strCurrentDBName As String
Static strPath As String
Dim i As Integer
If Len(strPath) = 0 Then
strCurrentDBName = CurrentDb.Name
For i = Len(strCurrentDBName) To 1 Step -1
If Mid(strCurrentDBName, i, 1) = "" Then
strPath = Left(strCurrentDBName, i)
Exit For
End If
Next
End If
CurrentPath = strPath
End Function
这有优势，它只会循环一次姓名。
当然，它只适用于用户界面中打开的文件。
另一种写法是在上面的函数中使用链接提供的函数，如下：
Public Function CurrentPath() As String
Static strPath As String
If Len(strPath) = 0 Then
strPath = FolderFromPath(CurrentDB.Name)
End If
CurrentPath = strPath
End Function
这使得检索当前路径非常高效，同时利用可以用于查找任何文件名/路径的代码。
vFilename="C:InformesIndicadoresProgramInd_Cont_PRv.txt" v文件名="C:InformesIndicadoresProgramInd_Cont_PRv.txt"
vDirFile = Replace(vFilename, Dir(vFileName, vbDirectory), "") vDirFile = 用（vFilename，Dir（vFileName，vbDirectory），""）替换
结果= C: InformesIndicadores_ContraloriaProgramaVersiones anteriores
left(currentdb.Name,instr(1,currentdb.Name,dir(currentdb.Name))-1) 的中文翻译为：在当前数据库名称中，返回其目录前的部分。
Dir功能仅返回完整路径的文件部分。此处使用Currentdb.Name，但它可以是任何完整路径字符串。
如果您对输入参数很有信心，您可以使用这个单行代码，它使用本机的Split和Join函数以及Excel本机的Application.pathSeparator。
Split(Join(Split(strPath, "."), Application.pathSeparator), Application.pathSeparator)
如果您需要更加全面的功能，下面的代码已经在Windows上进行了测试，并且应该也可以在Mac上运行（虽然没有进行测试）。一定要复制支持函数 GetPathSeparator，或修改代码以使用 Application.pathSeparator。请注意，这是第一版草稿；我应该将其重构为更加简洁。
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
otepad.exe", -2)
Debug.Print ParsePath2("C:WindowsSysWOW64", -2)
Debug.Print ParsePath2("C:WindowsSysWOW64", -2)
Debug.Print ParsePath2("C:WindowsSysWOW64AcLayers.dll", -2)
Debug.Print ParsePath2("C:WindowsSysWOW64.fakedir", -2)
Debug.Print ParsePath2("C:WindowsSysWOW64fakefile.ext", -2)
End If
If True Then
Debug.Print String(1, vbCrLf)
Debug.Print ParsePath2("Windows", -2)
Debug.Print ParsePath2("Windows
otepad.exe", -2)
Debug.Print ParsePath2("WindowsSysWOW64", -2)
Debug.Print ParsePath2("WindowsSysWOW64", -2)
Debug.Print ParsePath2("WindowsSysWOW64AcLayers.dll", -2)
Debug.Print ParsePath2("WindowsSysWOW64.fakedir", -2)
Debug.Print ParsePath2("WindowsSysWOW64fakefile.ext", -2)
End If
If True Then
Debug.Print String(1, vbCrLf)
Debug.Print ParsePath2("Windows
otepad.exe", -2)
Debug.Print ParsePath2("WindowsSysWOW64", -2)
Debug.Print ParsePath2("WindowsSysWOW64", -2)
Debug.Print ParsePath2("WindowsSysWOW64AcLayers.dll", -2)
Debug.Print ParsePath2("WindowsSysWOW64.fakedir", -2)
Debug.Print ParsePath2("WindowsSysWOW64fakefile.ext", -2)
Debug.Print ParsePath2(".fakedir", -2)
Debug.Print ParsePath2("fakefile.txt", -2)
Debug.Print ParsePath2("fakefile.onenote", -2)
Debug.Print ParsePath2("C:PersonalWorkspaceCodePythonVenvsxlwings_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 ""WindowsSysWOW64fakefile.ext"" with different ReturnType values"
Debug.Print , "{empty}", "D", ParsePath2("WindowsSysWOW64fakefile.ext")(1)
Debug.Print , "0", "D", ParsePath2("WindowsSysWOW64fakefile.ext", 0)(1)
Debug.Print , "1", "ext", ParsePath2("WindowsSysWOW64fakefile.ext", 1)
Debug.Print , "10", "file", ParsePath2("WindowsSysWOW64fakefile.ext", 10)
Debug.Print , "11", "file.ext", ParsePath2("WindowsSysWOW64fakefile.ext", 11)
Debug.Print , "100", "path", ParsePath2("WindowsSysWOW64fakefile.ext", 100)
Debug.Print , "110", "pathfile", ParsePath2("WindowsSysWOW64fakefile.ext", 110)
Debug.Print , "111", "pathfile.ext", ParsePath2("WindowsSysWOW64fakefile.ext", 111)
Debug.Print , "1000", "D", ParsePath2("WindowsSysWOW64fakefile.ext", 1000)
Debug.Print , "1100", "D:path", ParsePath2("WindowsSysWOW64fakefile.ext", 1100)
Debug.Print , "1110", "D:pfile", ParsePath2("WindowsSysWOW64fakefile.ext", 1110)
Debug.Print , "1111", "D:pf.ext", ParsePath2("WindowsSysWOW64fakefile.ext", 1111)
On Error GoTo EH:
This is expected to presetn an error:
p = "WindowsSysWOW64fakefile.ext"
n = 1010
Debug.Print "1010", "D:pfile.ext", ParsePath2("WindowsSysWOW64fakefile.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: foldersfilename.extension, excluding drive letter
1000: drive leter only
1100: drive:folders, excluding filename and extension
1110: drive:foldersfilename, 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:folderfile.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 Function
支持函数 GetPathSeparatorTest 扩展本机 Application.pathSeparator（或在需要时绕过）以在 Mac 和 Win 上工作。它还可以使用可选的路径字符串，并尝试确定在字符串中使用的路径分隔符（优先考虑操作系统本机的路径分隔符）。
Private Sub GetPathSeparatorTest()
Dim s As String
Debug.Print "GetPathSeparator(s):"
Debug.Print "s not provided: ", GetPathSeparator
s = "C:folder1folder2file.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 Function
支持函数（实际上被注释了，如果您不打算使用它，则可以跳过此项）。
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
请尝试这个功能：
Function FolderPath(FilePath As String) As String
--------------------------------------------------
Returns the folder path form the file path.
Written by: Christos Samaras
Date: 06/11/2013
--------------------------------------------------
Dim FileName As String
With WorksheetFunction
FileName = Mid(FilePath, .Find("*", .Substitute(FilePath, "", "*", Len(FilePath) - _
Len(.Substitute(FilePath, "", "")))) + 1, Len(FilePath))
End With
FolderPath = Left(FilePath, Len(FilePath) - Len(FileName) - 1)
End Function
如果您不想删除文件夹路径末尾的最后一个反斜杠“\”，请更改最后一行为：
FolderPath = Left(FilePath, Len(FilePath) - Len(FileName))
例子：
FolderPath("C：UsersChristosDesktopLAT 分析器信号校正1TP 14_03_2013_5.csv")
给予
C：UsersChristosDesktopLAT 分析器信号校正1
或者
C：UsersChristosDesktopLAT 分析器信号校正1
在第二种情况中（注意末尾有反斜杠）。
我希望它能帮上忙。
使用这些代码并享受它。
Public Function GetDirectoryName(ByVal source As String) As String()
Dim fso, oFolder, oSubfolder, oFile, queue As Collection
Set fso = CreateObject("Scripting.FileSystemObject")
Set queue = New Collection
Dim source_file() As String
Dim i As Integer
queue.Add fso.GetFolder(source) obviously replace
Do While queue.Count > 0
Set oFolder = queue(1)
queue.Remove 1 dequeue
...insert any folder processing code here...
For Each oSubfolder In oFolder.SubFolders
queue.Add oSubfolder enqueue
Next oSubfolder
For Each oFile In oFolder.Files
...insert any file processing code here...
Debug.Print oFile
i = i + 1
ReDim Preserve source_file(i)
source_file(i) = oFile
Next oFile
Loop
GetDirectoryName = source_file
End Function
这里你可以调用函数：
Sub test()
Dim s
For Each s In GetDirectoryName("C:New folder")
Debug.Print s
Next
End Sub