递归尝试使用关键字 (VBA-Access) 在文件夹中查找文件
Recusively trying to find file within folder using keyword (VBA-Access)
我正在创建一个带有下拉框 Combo_History 的 vba-access 应用程序，使用户能够从名为 "Scanned Work Orders (Archives)"。我想做的是使用一个叫做 "M" 数字的特定数字（M 数字，因为每个数字都以 M ex: M765196 开头）来查找这个文件，而不使用特定的子文件夹，这是我到目前为止所拥有的:
调暗 fso、oFolder、oSubfolder、oFile、作为集合排队
Set fso = CreateObject("Scripting.FileSystemObject")
Set queue = New Collection
queue.Add fso.GetFolder("T:\Scanned Work Orders (Archives)")
Do While queue.Count > 0
Set oFolder = queue(1)
queue.Remove 1 'dequeue
If oFile = Combo_History.Value Then
Application.FollowHyperlink ("T:\Scanned Work Orders (Archives)" & oFile)
End If
For Each oSubfolder In oFolder.SubFolders
queue.Add oSubfolder 'enqueue
Next oSubfolder
For Each oFile In oFolder.Files
If oFile = Combo_History.Value Then
Application.FollowHyperlink ("T:\Scanned Work Orders (Archives)" & oFile)
End If
Next oFile
Loop
问题是它陷入了无限循环，因为它找不到关键字名称为 M765196 的 .pdf，即使它位于该文件夹中。我缺少什么吗？或者更简单的方法来查找 .pdf 文件？
您的循环设置不太适合递归查找文件。下面的代码应该适合你。
此外，您正在为您的 FileSystemObjects 使用后期绑定 - 这非常好。但是你声明它们的方式导致它们都被评估为变体。这可能会很痛苦，但最好将每个变量 Dim 拆分为单独的行并准确指定它应该是什么类型。
Option Explicit
Sub test()
Dim fso As Object
Dim rootFolder As String
Dim filename As String
Dim fullpath As String
Set fso = CreateObject("Scripting.FileSystemObject")
rootFolder = "C:\Users\user\Documents"
filename = "testfile.txt"
fullpath = FindFile(fso, rootFolder, filename)
Debug.Print "file is ";
If Len(fullpath) > 0 Then
Debug.Print "FOUND! : " & fullpath
Else
Debug.Print "NOT found. Go look for it yourself!"
End If
End Sub
Function FindFile(fso As Object, thisFolder As String, filename As String) As String
On Error GoTo Error_FindFile
Dim fullFilePath As String
Dim oFolder As Object
Dim oSubfolder As Object
Set oFolder = fso.GetFolder(thisFolder)
'--- first check if the file is in the current folder
fullFilePath = oFolder.Path & "\" & filename
If fso.FileExists(fullFilePath) Then
'--- we're done, nothing more to do here
Else
'--- the file isn't in this folder, so check for any subfolders and search there
fullFilePath = ""
For Each oSubfolder In oFolder.SubFolders
Debug.Print "looking in " & oSubfolder.Path
If FindFile(fso, oSubfolder.Path, filename) <> "" Then
'--- found the file, so return the full path
fullFilePath = oSubfolder.Path & "\" & filename
Exit For
End If
Next oSubfolder
End If
Exit_FindFile:
FindFile = fullFilePath
Exit Function
Error_FindFile:
'--- we'll probably get mostly permission errors, so just skip (or log, or print out)
' the permission error and move on
If Err.Number = 70 Then
Debug.Print "Permission error on " & oSubfolder.Path
End If
GoTo Exit_FindFile
End Function
I'm adding a second answer here because solving for a wildcard differed more than I anticipated from the original.
使用通配符搜索文件并不困难，但它会带来一些影响，例如返回结果列表而不是单个结果。此外，幸运的是，我 运行 在我的一个子文件夹上遇到了权限错误，这让我开始考虑如何处理这种情况。
Option Explicit
Private recurseDepth As Integer
Sub test()
Dim rootFolder As String
Dim filename As String
Dim resultFiles() As String
Dim i As Integer
rootFolder = "C:\Temp"
filename = "*.pdf"
If FindFiles(rootFolder, filename, resultFiles) > 0 Then
For i = 1 To UBound(resultFiles)
Debug.Print Format(i, "00") & ": " & resultFiles(i)
Next i
Else
Debug.Print "No files found!"
End If
End Sub
Public Function FindFiles(thisFolder As String, filespec As String, _
ByRef fileList() As String) As Integer
'--- starts in the given folder and checks all files against the filespec.
' the filespec MAY HAVE A WILDCARD specified, so the function returns
' an array of full pathnames (strings) to each file that matches
' Parameters: thisFolder - string containing a full path to the root
' folder for the search
' filespec - string containing a single filename to
' search for, --or--
' string containing a wildcard string of
' files to search for
' (result==>)fileList - an array of strings, each will be a full
' path to a file matching the input filespec
' Returns: (integer) count of the files found that match the filespec
On Error GoTo Error_FindFile
Static fso As Object
Static pathCollection As Collection
Dim fullFilePath As String
Dim oFile As Object
Dim oFolder As Object
Dim oSubfolder As Object
'--- first time through, set up the working objects
If recurseDepth = 0 Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set pathCollection = New Collection
End If
recurseDepth = recurseDepth + 1
'--- focus on the given folder
Set oFolder = fso.GetFolder(thisFolder)
'--- first test if we have permissions to access the folder and
' if there are any files in the folder
On Error Resume Next
If oFolder.Files.Count > 0 Then
If Err.Number = 0 Then
'--- loop through all items in the folder. some are files and
' some are folders -- use recursion to search the subfolders
For Each oFile In oFolder.Files
If oFile.Name Like filespec Then
pathCollection.Add oFolder.Path & "\" & oFile.Name
End If
Next oFile
For Each oSubfolder In oFolder.SubFolders
FindFiles oSubfolder.Path, filespec, fileList
Next oSubfolder
Else
'--- if we get here it's usually a permissions error, so
' just skip this folder
Err.Clear
End If
End If
On Error GoTo Error_FindFile
Exit_FindFile:
recurseDepth = recurseDepth - 1
If (recurseDepth = 0) And (pathCollection.Count > 0) Then
'--- pull the paths out of the collection and make an array, because most
' programs uses arrays more easily
ReDim fileList(1 To pathCollection.Count)
Dim i As Integer
For i = 1 To pathCollection.Count
fileList(i) = pathCollection.Item(i)
Next i
End If
FindFiles = pathCollection.Count
Exit Function
Error_FindFile:
Debug.Print "Error (" & Err.Number & "): " & Err.Description & _
" on " & oSubfolder.Path
GoTo Exit_FindFile
End Function
This page 建议使用以下递归查找通配符的技术：
Sub Macro1()
Dim colFiles As New Collection
RecursiveDir colFiles, "C:\Photos\", "*.jpg", True
Dim vFile As Variant
For Each vFile In colFiles
Debug.Print vFile
Next vFile
End Sub
Public Function RecursiveDir(colFiles As Collection, _
strFolder As String, _
strFileSpec As String, _
bIncludeSubfolders As Boolean)
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add files in strFolder matching strFileSpec to colFiles
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colFiles.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Fill colFolders with list of subdirectories of strFolder
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call RecursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
If Right(strFolder, 1) = "\" Then
TrailingSlash = strFolder
Else
TrailingSlash = strFolder & "\"
End If
End If
End Function
我愿意为 PeterT 的解决方案做出贡献（第二个答案）！看来我没有足够的评论点数，所以我将其发布为答案。
我测试了解决方案并且它有效，但它有一些（小）错误！我没有在具有复杂权限的服务器上测试它，但在不久的将来我最终必须这样做！
- 如果 startFolder 为空（没有文件，但有子文件夹），该函数不会继续在 startFolders 的子文件夹中搜索。
- 搜索 A*.pdf 和 a*.PDF 不会给出相同的结果。鉴于 Windows 文件系统不区分大小写这一事实，进行不区分大小写的搜索是明智的。也许它不适用于 MAC?!
此外，我添加了两个（可选的）额外参数，垃圾收集代码和 FSO 对象的早期绑定（我更喜欢！）：
- boolean subFolders - 如果为 false，函数将不会搜索超出
开始文件夹
- boolean fullPath - 如果为 false，函数将 return 只有没有路径的文件名；有用（至少对我而言），尤其是当 subFolders=false.
- 搜索完成后 (recurseDepth = 0)，所有对象都设置为 Nothing。
代码如下：
Public Function FindFiles( _
ByVal startFolder As String, _
ByVal fileSpec As String, _
ByRef fileList() As String, _
Optional ByVal subFolders As Boolean = True, _
Optional ByVal fullPath As Boolean = True) _
As Long
'--- starts in the given folder and checks all files against the filespec.
' the filespec MAY HAVE A WILDCARD specified, so the function returns
' an array of files with or withour full pathnames (strings) to each file that matches
' Parameters: startFolder - string containing a full path to the root
' folder for the search
' fileSpec - string containing a single filename to
' search for, --or--
' string containing a wildcard string of
' files to search for
' (result==>)fileList - an array of strings, each will be a full
' path to a file matching the input filespec
' subFolders - include subfolders in startFolder
' fullPath - true=>fullFile path; false=>fileName only
' Returns: (integer) count of the files found that match the filespec
Dim fullFilePath As String
Dim Path As String
Static fso As FileSystemObject
Static pathCollection As Collection
Dim oFile As file
Dim oFolder As Folder
Dim oSubfolder As Folder
On Error GoTo Error_FindFile
'--- first time through, set up the working objects
If recurseDepth = 0 Then
Set fso = New FileSystemObject ' CreateObject("Scripting.FileSystemObject")
Set pathCollection = New Collection
End If
recurseDepth = recurseDepth + 1
'--- focus on the given folder
Set oFolder = fso.GetFolder(startFolder)
'--- first test if we have permissions to access the folder and
' if there are any files in the folder
On Error Resume Next
If oFolder.files.Count > 0 Or oFolder.subFolders.Count > 0 Then
If Err.Number = 0 Then
'--- loop through all items in the folder. some are files and
' some are folders -- use recursion to search the subfolders
If fullPath Then
Path = oFolder.Path & "\"
Else
Path = ""
End If
For Each oFile In oFolder.files
' If oFile.name Like fileSpec Then
If LCase(oFile.name) Like LCase(fileSpec) Then
pathCollection.Add Path & oFile.name
End If
Next oFile
If subFolders Then
For Each oSubfolder In oFolder.subFolders
FindFiles oSubfolder.Path, fileSpec, fileList, subFolders, fullPath
Next oSubfolder
End If
Else
'--- if we get here it's usually a permissions error, so
' just skip this folder
Err.Clear
End If
End If
On Error GoTo Error_FindFile
Exit_FindFile:
recurseDepth = recurseDepth - 1
If (recurseDepth = 0) Then
If (pathCollection.Count > 0) Then
'--- pull the paths out of the collection and make an array, because most
' programs uses arrays more easily
ReDim fileList(1 To pathCollection.Count)
Dim i As Integer
For i = 1 To pathCollection.Count
fileList(i) = pathCollection.Item(i)
Next i
End If
FindFiles = pathCollection.Count
Set fso = Nothing
Set pathCollection = Nothing
Set oFile = Nothing
Set oFolder = Nothing
Set oSubfolder = Nothing
End If
Exit Function
Error_FindFile:
Debug.Print "Error (" & Err.Number & "): " & Err.Description & _
" on " & oSubfolder.Path
GoTo Exit_FindFile
End Function
我正在创建一个带有下拉框 Combo_History 的 vba-access 应用程序，使用户能够从名为 "Scanned Work Orders (Archives)"。我想做的是使用一个叫做 "M" 数字的特定数字（M 数字，因为每个数字都以 M ex: M765196 开头）来查找这个文件，而不使用特定的子文件夹，这是我到目前为止所拥有的:
调暗 fso、oFolder、oSubfolder、oFile、作为集合排队
Set fso = CreateObject("Scripting.FileSystemObject")
Set queue = New Collection
queue.Add fso.GetFolder("T:\Scanned Work Orders (Archives)")
Do While queue.Count > 0
Set oFolder = queue(1)
queue.Remove 1 'dequeue
If oFile = Combo_History.Value Then
Application.FollowHyperlink ("T:\Scanned Work Orders (Archives)" & oFile)
End If
For Each oSubfolder In oFolder.SubFolders
queue.Add oSubfolder 'enqueue
Next oSubfolder
For Each oFile In oFolder.Files
If oFile = Combo_History.Value Then
Application.FollowHyperlink ("T:\Scanned Work Orders (Archives)" & oFile)
End If
Next oFile
Loop
问题是它陷入了无限循环，因为它找不到关键字名称为 M765196 的 .pdf，即使它位于该文件夹中。我缺少什么吗？或者更简单的方法来查找 .pdf 文件？
您的循环设置不太适合递归查找文件。下面的代码应该适合你。
此外，您正在为您的 FileSystemObjects 使用后期绑定 - 这非常好。但是你声明它们的方式导致它们都被评估为变体。这可能会很痛苦，但最好将每个变量 Dim 拆分为单独的行并准确指定它应该是什么类型。
Option Explicit
Sub test()
Dim fso As Object
Dim rootFolder As String
Dim filename As String
Dim fullpath As String
Set fso = CreateObject("Scripting.FileSystemObject")
rootFolder = "C:\Users\user\Documents"
filename = "testfile.txt"
fullpath = FindFile(fso, rootFolder, filename)
Debug.Print "file is ";
If Len(fullpath) > 0 Then
Debug.Print "FOUND! : " & fullpath
Else
Debug.Print "NOT found. Go look for it yourself!"
End If
End Sub
Function FindFile(fso As Object, thisFolder As String, filename As String) As String
On Error GoTo Error_FindFile
Dim fullFilePath As String
Dim oFolder As Object
Dim oSubfolder As Object
Set oFolder = fso.GetFolder(thisFolder)
'--- first check if the file is in the current folder
fullFilePath = oFolder.Path & "\" & filename
If fso.FileExists(fullFilePath) Then
'--- we're done, nothing more to do here
Else
'--- the file isn't in this folder, so check for any subfolders and search there
fullFilePath = ""
For Each oSubfolder In oFolder.SubFolders
Debug.Print "looking in " & oSubfolder.Path
If FindFile(fso, oSubfolder.Path, filename) <> "" Then
'--- found the file, so return the full path
fullFilePath = oSubfolder.Path & "\" & filename
Exit For
End If
Next oSubfolder
End If
Exit_FindFile:
FindFile = fullFilePath
Exit Function
Error_FindFile:
'--- we'll probably get mostly permission errors, so just skip (or log, or print out)
' the permission error and move on
If Err.Number = 70 Then
Debug.Print "Permission error on " & oSubfolder.Path
End If
GoTo Exit_FindFile
End Function
I'm adding a second answer here because solving for a wildcard differed more than I anticipated from the original.
使用通配符搜索文件并不困难，但它会带来一些影响，例如返回结果列表而不是单个结果。此外，幸运的是，我 运行 在我的一个子文件夹上遇到了权限错误，这让我开始考虑如何处理这种情况。
Option Explicit
Private recurseDepth As Integer
Sub test()
Dim rootFolder As String
Dim filename As String
Dim resultFiles() As String
Dim i As Integer
rootFolder = "C:\Temp"
filename = "*.pdf"
If FindFiles(rootFolder, filename, resultFiles) > 0 Then
For i = 1 To UBound(resultFiles)
Debug.Print Format(i, "00") & ": " & resultFiles(i)
Next i
Else
Debug.Print "No files found!"
End If
End Sub
Public Function FindFiles(thisFolder As String, filespec As String, _
ByRef fileList() As String) As Integer
'--- starts in the given folder and checks all files against the filespec.
' the filespec MAY HAVE A WILDCARD specified, so the function returns
' an array of full pathnames (strings) to each file that matches
' Parameters: thisFolder - string containing a full path to the root
' folder for the search
' filespec - string containing a single filename to
' search for, --or--
' string containing a wildcard string of
' files to search for
' (result==>)fileList - an array of strings, each will be a full
' path to a file matching the input filespec
' Returns: (integer) count of the files found that match the filespec
On Error GoTo Error_FindFile
Static fso As Object
Static pathCollection As Collection
Dim fullFilePath As String
Dim oFile As Object
Dim oFolder As Object
Dim oSubfolder As Object
'--- first time through, set up the working objects
If recurseDepth = 0 Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set pathCollection = New Collection
End If
recurseDepth = recurseDepth + 1
'--- focus on the given folder
Set oFolder = fso.GetFolder(thisFolder)
'--- first test if we have permissions to access the folder and
' if there are any files in the folder
On Error Resume Next
If oFolder.Files.Count > 0 Then
If Err.Number = 0 Then
'--- loop through all items in the folder. some are files and
' some are folders -- use recursion to search the subfolders
For Each oFile In oFolder.Files
If oFile.Name Like filespec Then
pathCollection.Add oFolder.Path & "\" & oFile.Name
End If
Next oFile
For Each oSubfolder In oFolder.SubFolders
FindFiles oSubfolder.Path, filespec, fileList
Next oSubfolder
Else
'--- if we get here it's usually a permissions error, so
' just skip this folder
Err.Clear
End If
End If
On Error GoTo Error_FindFile
Exit_FindFile:
recurseDepth = recurseDepth - 1
If (recurseDepth = 0) And (pathCollection.Count > 0) Then
'--- pull the paths out of the collection and make an array, because most
' programs uses arrays more easily
ReDim fileList(1 To pathCollection.Count)
Dim i As Integer
For i = 1 To pathCollection.Count
fileList(i) = pathCollection.Item(i)
Next i
End If
FindFiles = pathCollection.Count
Exit Function
Error_FindFile:
Debug.Print "Error (" & Err.Number & "): " & Err.Description & _
" on " & oSubfolder.Path
GoTo Exit_FindFile
End Function
This page 建议使用以下递归查找通配符的技术：
Sub Macro1()
Dim colFiles As New Collection
RecursiveDir colFiles, "C:\Photos\", "*.jpg", True
Dim vFile As Variant
For Each vFile In colFiles
Debug.Print vFile
Next vFile
End Sub
Public Function RecursiveDir(colFiles As Collection, _
strFolder As String, _
strFileSpec As String, _
bIncludeSubfolders As Boolean)
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add files in strFolder matching strFileSpec to colFiles
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colFiles.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Fill colFolders with list of subdirectories of strFolder
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call RecursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
If Right(strFolder, 1) = "\" Then
TrailingSlash = strFolder
Else
TrailingSlash = strFolder & "\"
End If
End If
End Function
我愿意为 PeterT 的解决方案做出贡献（第二个答案）！看来我没有足够的评论点数，所以我将其发布为答案。
我测试了解决方案并且它有效，但它有一些（小）错误！我没有在具有复杂权限的服务器上测试它，但在不久的将来我最终必须这样做！
- 如果 startFolder 为空（没有文件，但有子文件夹），该函数不会继续在 startFolders 的子文件夹中搜索。
- 搜索 A*.pdf 和 a*.PDF 不会给出相同的结果。鉴于 Windows 文件系统不区分大小写这一事实，进行不区分大小写的搜索是明智的。也许它不适用于 MAC?!
此外，我添加了两个（可选的）额外参数，垃圾收集代码和 FSO 对象的早期绑定（我更喜欢！）：
- boolean subFolders - 如果为 false，函数将不会搜索超出 开始文件夹
- boolean fullPath - 如果为 false，函数将 return 只有没有路径的文件名；有用（至少对我而言），尤其是当 subFolders=false.
- 搜索完成后 (recurseDepth = 0)，所有对象都设置为 Nothing。
代码如下：
Public Function FindFiles( _
ByVal startFolder As String, _
ByVal fileSpec As String, _
ByRef fileList() As String, _
Optional ByVal subFolders As Boolean = True, _
Optional ByVal fullPath As Boolean = True) _
As Long
'--- starts in the given folder and checks all files against the filespec.
' the filespec MAY HAVE A WILDCARD specified, so the function returns
' an array of files with or withour full pathnames (strings) to each file that matches
' Parameters: startFolder - string containing a full path to the root
' folder for the search
' fileSpec - string containing a single filename to
' search for, --or--
' string containing a wildcard string of
' files to search for
' (result==>)fileList - an array of strings, each will be a full
' path to a file matching the input filespec
' subFolders - include subfolders in startFolder
' fullPath - true=>fullFile path; false=>fileName only
' Returns: (integer) count of the files found that match the filespec
Dim fullFilePath As String
Dim Path As String
Static fso As FileSystemObject
Static pathCollection As Collection
Dim oFile As file
Dim oFolder As Folder
Dim oSubfolder As Folder
On Error GoTo Error_FindFile
'--- first time through, set up the working objects
If recurseDepth = 0 Then
Set fso = New FileSystemObject ' CreateObject("Scripting.FileSystemObject")
Set pathCollection = New Collection
End If
recurseDepth = recurseDepth + 1
'--- focus on the given folder
Set oFolder = fso.GetFolder(startFolder)
'--- first test if we have permissions to access the folder and
' if there are any files in the folder
On Error Resume Next
If oFolder.files.Count > 0 Or oFolder.subFolders.Count > 0 Then
If Err.Number = 0 Then
'--- loop through all items in the folder. some are files and
' some are folders -- use recursion to search the subfolders
If fullPath Then
Path = oFolder.Path & "\"
Else
Path = ""
End If
For Each oFile In oFolder.files
' If oFile.name Like fileSpec Then
If LCase(oFile.name) Like LCase(fileSpec) Then
pathCollection.Add Path & oFile.name
End If
Next oFile
If subFolders Then
For Each oSubfolder In oFolder.subFolders
FindFiles oSubfolder.Path, fileSpec, fileList, subFolders, fullPath
Next oSubfolder
End If
Else
'--- if we get here it's usually a permissions error, so
' just skip this folder
Err.Clear
End If
End If
On Error GoTo Error_FindFile
Exit_FindFile:
recurseDepth = recurseDepth - 1
If (recurseDepth = 0) Then
If (pathCollection.Count > 0) Then
'--- pull the paths out of the collection and make an array, because most
' programs uses arrays more easily
ReDim fileList(1 To pathCollection.Count)
Dim i As Integer
For i = 1 To pathCollection.Count
fileList(i) = pathCollection.Item(i)
Next i
End If
FindFiles = pathCollection.Count
Set fso = Nothing
Set pathCollection = Nothing
Set oFile = Nothing
Set oFolder = Nothing
Set oSubfolder = Nothing
End If
Exit Function
Error_FindFile:
Debug.Print "Error (" & Err.Number & "): " & Err.Description & _
" on " & oSubfolder.Path
GoTo Exit_FindFile
End Function