问题
I am creating an vba-access application with a drop down box Combo_History that gives the user the ability to launch a .pdf file from a sub-folder within a main folder called "Scanned Work Orders (Archives)". What I am trying to do is use a certain number called an "M" number(M number because every number starts with an M ex: M765196) to find this file without using a specific sub folder here is what i have so far:
Dim fso, oFolder, oSubfolder, oFile, queue As Collection
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
The problem is it gets stuck in an infinite loop because it cannot find the .pdf with the keyword name M765196 even though it is in that folder. Is there something im missing? Or an easier way to find the .pdf file?
回答1:
I'm adding a second answer here because solving for a wildcard differed more than I anticipated from the original.
Searching for files using a wildcard isn't difficult, but it comes with some implications, such as returning a list of results instead of a single result. In addition, I fortunately ran into a permissions error on one of my subfolders which caused me to think about how to handle that situation.
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
回答2:
Your loop setup didn't lend itself very well to recursion in looking for the file. The code below should work for you.
Also, you're using late-binding for your FileSystemObjects - which is perfectly fine. But the way you have them declared causes them all to be evaluated as Variants. It may be a pain, but it's better to break out each variable Dim on as separate line and to exactly specify what type it should be.
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
回答3:
This page suggests the following technique for finding a wildcard recursively:
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
回答4:
I'd like to contribute to PeterT's solution (second answer)! It appears I don't have enough points to comment, so I'm posting this as an answer.
I tested the solution and it works, but it has some (minor) bugs! I didn't test it on a server with complicated privileges, but I'll eventually have to do that in the near future!
- If the startFolder is empty (no files, but subfolders) the function doesn't continue to search in startFolders' subfolders.
- Search for A*.pdf and a*.PDF will not give the same result. Given the fact that Windows file system is case insensitive, it's wise to have case insensitive search. Perhaps it won't work on MAC?!
In addition, I added two (optional) extra parameters, code for garbage collection and early binding for FSO objects (I prefer that!):
- boolean subFolders - if false the function will not search beyond the startFolder
- boolean fullPath - if false the function will return only file names without the path; useful (at least to me) especially if subFolders=false.
- After the search finishes (recurseDepth = 0) all objects are set to Nothing.
Here is the code:
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
来源：https://stackoverflow.com/questions/31385523/recusively-trying-to-find-file-within-folder-using-keyword-vba-access