VBA- filter unecessary folders - vba

I have a question about reading files within folders. I found this code:
sub sample()
Dim FileSystem As Object
Dim HostFolder As String
HostFolder = "C:\"
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
end sub
Sub DoFolder(Folder)
Dim SubFolder
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
Dim File
For Each File In Folder.Files
' Operate on each file
Next
End Sub
But how would you go about avoiding a specific folder which is within the original one?
Let's say the you have a folder A which in turn has several folder Bs. within these folders, there are the file required but also another folder, always with the same name, let's say C.
How would you filter out folders Cs?
Thank you for your time

You can try something like this:
' List of complete path of files in folder / subfolders
' Needs to add "Microsoft Scripting Runtime" reference to your file
Sub FolderFilesPath(ByVal pFolder As String, ByRef pColFiles As Collection, _
Optional ByVal pGetSubFolders As Boolean, Optional ByVal pFilter As Collection)
Dim sFolder As String
Dim oFSO As New FileSystemObject
Dim oFolder, oSubFolder As Folder
Dim oFile As File
sFolder = IIf(Right(pFolder, 1) <> "\", pFolder & "\", pFolder)
Set oFolder = oFSO.GetFolder(sFolder)
If Not ExistsInCollection(pFilter, sFolder) Then
For Each oFile In oFolder.Files
pColFiles.Add oFile
Next oFile
If pGetSubFolders Then
For Each oSubFolder In oFolder.SubFolders
FolderFilesPath oSubFolder.Path, pColFiles, pGetSubFolders, pFilter
Next
End If
End If
End Sub
' Vba collection contains
Function ExistsInCollection(col As Collection, key As Variant) As Boolean
On Error GoTo err
ExistsInCollection = True
IsObject (col.Item(key))
Exit Function
err:
ExistsInCollection = False
End Function
'------------------------------------------------------------------------------
Sub TestMe()
Dim colFiles As New Collection, sFilePath As Variant
Dim colExcludedFolders As New Collection
Dim sHostFolder As String
sHostFolder = "C:\temp"
With colExcludedFolders
' add folders you want to exclude
.Add sHostFolder & "\C\", sHostFolder & "\C\"
End With
FolderFilesPath ThisWorkbook.Path, colFiles, True, colExcludedFolders
' colFiles contains filtered files
For Each sFilePath In colFiles
With sFilePath
' do what you want with filtered files
Debug.Print .Path & " - " & .Name & " - " & .DateCreated
End With
Next sFilePath
End Sub

Related

How to make this code apply recursively to all sub-folders

I found this code to change .doc files to .docx files. I would like to modify it so I can specify a top level folder and have it work through it AND every sub-folder. Appreciate any assistance.
Sub TranslateDocIntoDocx()
Dim objWordApplication As New Word.Application
Dim objWordDocument As Word.Document
Dim strFile As String
Dim strFolder As String
strFolder = "C:\Temp\doc\"
strFile = Dir(strFolder & "*.doc", vbNormal)
While strFile <> ""
With objWordApplication
Set objWordDocument = .Documents.Open(FileName:=strFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With objWordDocument
.SaveAs FileName:=strFolder & Replace(strFile, "doc", "docx"), FileFormat:=16
.Close
End With
End With
strFile = Dir()
Wend
Set objWordDocument = Nothing
Set objWordApplication = Nothing
End Sub
I suggest switching from Dir to FileSystemObject. With FSO, you can get a folder as an object with GetFolder and then access the Folder Object's files and folders as collections. This enables For Each loops like For Each File In Folder. and then you can do the recursion For Each SubFolder In Folder where you can re-call the macro as if each subfolder was the top level folder.
Sub TranslateDocIntoDocx()
Dim objWordApplication As New Word.Application
Dim strFolder As String
strFolder = "C:\Temp\doc\"
Dim StartingFolder As Object
Set StartingFolder = CreateObject("Scripting.FileSystemObject").GetFolder(strFolder)
FolderToDocx StartingFolder, objWordApplication
Set objWordApplication = Nothing
End Sub
Sub FolderToDocx(Folder As Object, wdApp As Word.Application)
Dim File As Object
For Each File In Folder.Files
If LCase(Split(File.Name, ".")(1)) = "doc" Then SaveToDocx File, wdApp
Next
Dim SubFolder As Object
For Each SubFolder In Folder.Subfolders
FolderToDocx SubFolder, wdApp
Next
End Sub
Sub SaveToDocx(File As Object, wdApp As Word.Application)
With wdApp.Documents.Open(File.Path, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
.SaveAs Filename:=File.Path & "x"), FileFormat:=16
.Close
End With
End Sub
The file matching expression I did in this answer is just an example. You may want to improve that expression to prevent errors. One error that may come up is with Microsoft Office temp files. They are usually hidden and prefixed with ~$ like ~$Word Document.docx. So to avoid accidentally matching one of those, it would be good to exclude anything with that prefix.
I would recommend splitting out the file searching into a separate function: it's easier to tweak your logic and the main method doesn't get overloaded by the code for finding the files.
Sub TranslateDocIntoDocx()
Dim objWordApplication As New Word.Application
Dim objWordDocument As Word.Document
Dim colFiles As Collection
Dim strFile
Set colFiles = GetMatchingFiles("C:\Temp\doc\", "*.doc")
For Each strFile In colFiles
With objWordApplication
Set objWordDocument = .Documents.Open(Filename:=strFile, _
AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With objWordDocument
.SaveAs Filename:=strFile & "x", FileFormat:=16
.Close
End With
End With
Next strFile
End Sub
'Search beginning at supplied folder root, including subfolders, for
' files matching the supplied pattern. Return all matches in a Collection
Function GetMatchingFiles(startPath As String, filePattern As String) As Collection 'of paths
Dim colFolders As New Collection, colFiles As New Collection
Dim fso As Object, fldr, subfldr, fl
Set fso = CreateObject("scripting.filesystemobject")
colFolders.Add startPath 'queue up root folder for processing
Do While colFolders.Count > 0 'loop until the queue is empty
fldr = colFolders(1) 'get next folder from queue
colFolders.Remove 1 'remove current folder from queue
With fso.getfolder(fldr)
For Each fl In .Files
If UCase(fl.Name) Like UCase(filePattern) Then 'check pattern
colFiles.Add fl.Path 'collect the full path
End If
Next fl
For Each subfldr In .subFolders
colFolders.Add subfldr.Path 'queue any subfolders
Next subfldr
End With
Loop
Set GetMatchingFiles = colFiles
End Function

Issue in looping through various subfolders of folder and each files of these subfolders

I want to access each subfolder of my current folder(number of subfolders in each sub folder may vary) and then want to perform some operations in each excel workbook of all these subfolders.
Below mentioned is the code and code is not throwing compile time error but not working. Kindly help me
option explicit
Sub LoopFolders()
Dim strFolder As String
Dim strSubFolder As String
Dim strFile As String
Dim colSubFolders As New Collection
Dim varItem As Variant
Dim wbk As Workbook
' Parent folder including trailing backslash
strFolder = "C:\Users\Yashika Vaish\Desktop\yashika\"
' Loop through the subfolders and fill Collection object
strSubFolder = Dir(strFolder & "*", vbDirectory)
Do While Not strSubFolder = ""
Select Case strSubFolder
Case ".", ".."
' Current folder or parent folder - ignore
Case Else
' Add to collection
colSubFolders.Add Item:=strSubFolder, Key:=strSubFolder
End Select
' On to the next one
strSubFolder = Dir
Loop
' Loop through the collection
For Each varItem In colSubFolders
' Loop through Excel workbooks in subfolder
strFile = Dir(strFolder & varItem & "\*.xls*")
Do While strFile <> ""
' Open workbook
Set wbk = Workbooks.Open(FileName:=strFolder & _
varItem & "\" & strFile, AddToMRU:=False)
MsgBox "I am open"
strFile = Dir
Loop
Next varItem
End Sub
All the required references in tools settings have already been added in this VBA Project. Kindly help me with this code.
The method below writes the file names from the subfolders too to the workbook. So it finds them.
Sub Program()
Dim i As Integer
i = 1
listFiles "D:\Folder 1", i
End Sub
Sub listFiles(ByVal sPath As String, ByRef i As Integer)
Dim vaArray As Variant
Dim oFile As Object
Dim oFSO As Object
Dim oFolder As Object
Dim oFiles As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(sPath)
Set oFiles = oFolder.Files
If (oFiles.Count > 0) Then
ReDim vaArray(1 To oFiles.Count)
For Each oFile In oFiles
Cells(i, "A").Value = oFile.Name
Cells(i, "B").Value = oFile.Path
i = i + 1
Next
End If
listFolders sPath, i
End Sub
Sub listFolders(ByVal sPath As String, ByRef i As Integer)
Dim vaArray As Variant
Dim oFile As Object
Dim oFSO As Object
Dim oFolder As Object
Dim oFiles As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(sPath)
Set oFiles = oFolder.subfolders
If (oFiles.Count > 0) Then
ReDim vaArray(1 To oFiles.Count)
For Each oFile In oFiles
listFiles oFile.Path, i
i = i + 1
Next
End If
End Sub
This is what I use & it's a #WorksAtMyBox certified code ;)
Option Explicit
Dim fso As Scripting.FileSystemObject
Dim fsoMainDirectory As Scripting.folder
Dim fsoSubfolder As Scripting.folder
Dim fsoFile As Scripting.file
Dim strFilePath
Dim filecounter As Long
Dim foldercounter As Long
Public Sub FileFinder(fileorfolder As String)
If fso Is Nothing Then
Set fso = New Scripting.FileSystemObject
End If
Set fsoMainDirectory = fso.GetFolder(fileorfolder)
If fsoMainDirectory.SubFolders.Count > 0 Then
For Each fsoSubfolder In fsoMainDirectory.SubFolders
foldercounter = foldercounter + 1
Debug.Print "Folder: " & foldercounter & fsoSubfolder.Path
FileFinder (fsoSubfolder.Path)
Next fsoSubfolder
End If
If fsoMainDirectory.Files.Count > 0 Then
For Each fsoFile In fsoMainDirectory.Files
ProcessFile (fsoFile.Path)
Next fsoFile
End If
End Sub
Public Sub ProcessFile(file As String)
filecounter = filecounter + 1
Debug.Print "File: " & filecounter & ": " & file
End Sub
So, here is how I search through a folder looking for a specific file type. (early binding is your friend at this point in development). Make sure you have the Microsoft Scripting Runtime reference enabled.
Option Explicit
Sub test()
Dim fso As Scripting.FileSystemObject
Dim fsoMainDirectory As Scripting.Folder
Dim fsoSubfolder As Scripting.Folder
Dim fsoFile As Scripting.File
Dim strFilePath
Set fso = New Scripting.FileSystemObject
Set fsoMainDirectory = fso.GetFolder("Directory, with trailing \")
For Each fsoFile In fsoMainDirectory.Files
If fsoFile.Type = "Microsoft Excel 97-2003 Worksheet" Then '.xls file type
strFilePath = fsoFile.Path
Application.Workbooks.Open strFilePath
End If
Next fsoFile
End Sub
How deep do your sub folders go? Are you the only one will use this macro? Looping through n subfolders with an unknown number of subfolders is doable, but my method involves an array of counters. This array can lower performance, and as such don't want to do that if we don't need to.

VBA search for a specific subfolder in many folders and move all the files in it

can you help me?
i want a macro vba that search for a SPECIFIC subfolder for example (Xfolder) between all the folders and subfolders that exist and move their files.
P:\Desktop\Folder1\subfolder\SUBFOLDER1\Xfolder
I'm using the VBA Scripting Runtime objects
Set oSourceFolder = fso.GetFolder(source)
If Dir(destinationFolder, 16) = "" Then MkDir (destinationFolder)
For Each oFile In oFolder.Files
If Dir(destinationFolder,16) = "" Then
fso.MoveFile oFile.Path, destinationFolder
End If
Next oFile
fso.DeleteFolder oFolder.Path
Next oFolder
Here's a solution:
Dim fsoFileSystem As New FileSystemObject
Dim foFolder As Folder, foSubFolder As Folder
Dim fFile As File
Dim strStartFolder As String, strMoveFolder As String, strTargetFolder As String
strStartFolder = "\\A\B\C"
strMoveFolder = "SearchFolder"
strTargetFolder = "\\B\D\E"
Set foFolder = fsoFileSystem.GetFolder(strStartFolder)
For Each foSubFolder In foFolder.SubFolders
If foSubFolder.Name = strMoveFolder Then
For Each fFile In foSubFolder.Files
fsoFileSystem.MoveFile fFile, strTargetFolder & "\"
Next
End If
Next
strStartFolder is the folder to Screen for subfolders.
strMoveFolder is the name of the Folder to look for.
strTargetFolder is the Folder to where all the strMoveFolder's files shall be moved.
To found some folder use something like this
Sub findFolder()
Dim searchFolderName As String
searchFolderName = "somePath"
Dim FileSystem As Object
Set FileSystem = CreateObject("Scripting.FileSystemObject")
doFolder FileSystem.getFolder(searchFolderName)
End Sub
Sub doFolder(Folder)
Dim subFolder
On Error Resume Next
For Each subFolder In Folder.subfolders
If Split(subFolder, "\")(UBound(Split(subFolder, "\"))) = "testFolder" Then
MsgBox "gotcha"
End
End If
doFolder subFolder
Next subFolder
End Sub
And then you can do whatever with that folder and its content. So with i little use of google (one maybe two words) you can achieve what you wana

Find and List File Names Augment to Include Subfolders

I have two codes. One will search and name every folder within a directory. The other will list the files and file names within a single folder. I am not proficient enough with VBA to figure this out, so I need StackOverflow!
Here is the File Name Listing program:
Sub Example1()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("\\fc8fsp01\litho_recipe_amat_data")
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name
Cells(i + 1, 1) = objFile.Name
'print file path
Cells(i + 1, 2) = objFile.Path
i = i + 1
Next objFile
End Sub
Here is the second code that will navigate sub-folders to write folder names:
Option Explicit
Dim i As Long, j As Long
Dim searchfolders As Variant
Dim FileSystemObject
Sub ListOfFolders()
Dim LookInTheFolder As String
i = 1
LookInTheFolder = "\D: ' As you know; you should modificate this row.
Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
For Each searchfolders In FileSystemObject.GetFolder(LookInTheFolder).SubFolders
Cells(i, 1) = searchfolders
i = i + 1
SearchWithin searchfolders
Next searchfolders
End Sub
Sub SearchWithin(searchfolders)
On Error GoTo exits
For Each searchfolders In FileSystemObject.GetFolder(searchfolders).SubFolders
j = UBound(Split(searchfolders, "\"))
Cells(i, j) = searchfolders
i = i + 1
SearchWithin searchfolders
Next searchfolders
exits:
End Sub
I need a code that will search all sub folders and list all files contained. Please help D:
Because of speed issues when some of the folders I was accessing were present on a network drive, I wrote a little VBA program that uses the Windows Shell dir command. With the proper arguments, this will return all the files in the base directory; as well as all the subfolders and files and so forth. I have it write the results to a text file, which I then read into Excel for further processing.
Compared with using VBA's DIR or the FSO, this ran about five times faster when the files were on a network drive -- not so noticeable when on the local computer -- but I present it as another approach.
You must set a reference to Windows Script Host Object Model.
sDrive and sBasePath are used to set the starting folder name.
sFileList is where the results will be written into a text file.
The /S argument Displays files in specified directory and all subdirectories.
The /B argument results in omitting heading information and summary
If you run CMD.EXE and look for help on the dir command, you will see an explanation of the other arguments.
Public sDrive As String
Public sBasePath As String
Public Const sFileList As String = "C:\Users\Ron\FileList.txt"
Option Explicit
Sub GetDirTree()
Dim WSH As WshShell
Dim lErrCode As Long
Set WSH = New WshShell
lErrCode = WSH.Run("cmd.exe /c dir """ & sDrive & sBasePath & """/B /S >" & sFileList, 0, True)
If lErrCode <> 0 Then
MsgBox ("Error in GetDirTree: Error Number: " & CStr(lErrCode))
Stop
End If
End Sub
This is the function I use to find all files in a directory.
Public Function RecursiveDir(colFiles As Collection, _
ByVal 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
'Fill colFolders with list of subdirectories of strFolder
If bIncludeSubfolders Then
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
'Garbage collection
Set colFolders = Nothing
End Function
This function will populate a collection of every file name in a given directory. And if you want you can set the bIncludeSubfolders to True, and it will recursively search all subfolders within this directory. To use this function, you need the following:
Dim colFiles As New Collection ' The collection of files
Dim Path As String ' The parent Directory you want to search
Dim subFold As Boolean ' Search sub folders, yes or no?
Dim FileExt As String ' File extension type to search for
Then just set FileExt = "*.*" Which will find every file with every file extension. Hopefully this helps a little more.

Recusively trying to find file within folder using keyword (VBA-Access)

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?
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
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
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
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