Finding a specific file across several subfolders?

[Trex_tony]

Hi folks,

I am trying to firstly get a list of subfolders within a given folder, then get a specific filename from within each subfolder (they have different names but all end with "*Mosaix.zvi)

I am having considerable trouble with this, as the first part is trivial but the second part is proving quite difficult for a VBA novice like myself!

I have approached it in 2 ways, using Dir (which crashes instantly when running) and FSO (which doesn't return the filenames at all), as follows:


Sub loopThroughAllFolders()

Dim basePath, fileSearch, fileName, folderPathString, filePathString, filePath, subFolders As String
Dim idx As Integer


basePath = "F:\Petrography Images\"
fileSearch = "*Mosaix.zvi"
idx = 0


subFolders = Dir(basePath, vbDirectory)


Do While subFolders <> ""
If subFolders <> "." And subFolders <> ".." Then


idx = idx + 1
folderPathString = basePath & subFolders & "\"

If GetAttr(folderPathString) = vbDirectory Then
filePathString = folderPathString & fileSearch
fileName = Dir(filePathString, vbDirectory)
filePath = folderPathString & fileName
End If


Cells(idx, 1).Value = subFolders
Cells(idx, 2).Value = fileName
subFolders = Dir()


End If
Loop


End Sub




and FSO:


Sub LoopSubfoldersAndFiles()
Dim fso As Object, folder As Object, subfolders As Object, allFiles As Variant
Dim MyFile As String, fileStr As String
Dim idxFolders , idxFiles As Integer
Dim folderCount As Integer
Dim arrFolders(), arrFiles() As String


Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder("F:\Petrography Images\")
Set subfolders = folder.subfolders
fileStr = "*Mosaix.zvi"

idxFolders = 0
idxFiles = 0
folderCount = subfolders.Count

If folderCount > 0 Then
ReDim arrFolders(1 To folderCount)
ReDim arrFiles(1 To folderCount)
End If

For Each subfolders In subfolders
idxFolders = idxFolders + 1
arrFolders(idxFolders) = subfolders.Name

For Each allFiles In subfolders.Files
If InStr(allFiles.Name, "*Mosaix.zvi") > 0 Then
idxFiles = idxFiles + 1
fileNames(idxFiles) = allFiles.Name
End If

Next
Next

Range("A1").Resize(folderCount).Value = Application.Transpose(arrFolders)
Range("B1").Resize(idxFiles).Value = Application.Transpose(fileNames)

Set fso = Nothing
Set folder = Nothing
Set subfolders = Nothing


End Sub


Any help in solving this would be greatly appreciated!

[arnelgp]

maybe something like this (ctto)

Private Sub Test()
Dim lst As ListBox
Dim i As Long


'ListFiles Environ$("userProfile") & "\Documents", "*.*", True, lst
ListFiles "F:\Petrography Images", "*Mosaix.zvi", True, lst


On Error Resume Next
For i = 0 To lst.ListCount - 1
Debug.Print lst.List(i).Value
Next
End Sub


Public Function ListFiles(ByVal strPath As String, Optional ByVal strFileSpec As String = "*.*", _
Optional ByVal bIncludeSubfolders As Boolean = False, Optional ByRef lst As ListBox = Nothing)
On Error GoTo Err_Handler
'Purpose: List the files in the path.
'Arguments: strPath = the path to search.
' strFileSpec = "*.*" unless you specify differently.
' bIncludeSubfolders: If True, returns results from subdirectories of strPath as well.
' lst: if you pass in a list box, items are added to it. If not, files are listed to immediate window.
' The list box must have its Row Source Type property set to Value List.
'Method: FilDir() adds items to a collection, calling itself recursively for subfolders.
Dim colDirList As New Collection
Dim varItem As Variant

Call FillDir(colDirList, strPath, strFileSpec, bIncludeSubfolders)

'Add the files to a list box if one was passed in. Otherwise list to the Immediate Window.
If lst Is Nothing Then
For Each varItem In colDirList

Debug.Print varItem
DoEvents

Next
Else
For Each varItem In colDirList
lst.AddItem varItem
Next
End If


Exit_Handler:
Exit Function


Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume Exit_Handler
End Function


Private Function FillDir(colDirList As Collection, ByVal strFolder As String, strFileSpec As String, _
bIncludeSubfolders As Boolean)
'Build up a list of files, and then add add to this list, any additional folders
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant


On Error Resume Next
'Add the files to the folder.
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colDirList.Add strFolder & strTemp
strTemp = Dir
Loop


If bIncludeSubfolders Then
'Build collection of additional subfolders.
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 function recursively for each subfolder.
For Each vFolderName In colFolders
Call FillDir(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True)
Next vFolderName
End If
End Function


Public Function TrailingSlash(varIn As Variant) As String
If Len(varIn) > 0& Then
If Right(varIn, 1&) = "\" Then
TrailingSlash = varIn
Else
TrailingSlash = varIn & "\"
End If
End If
End Function

[Trex_tony]

maybe something like this (ctto)


Many thanks for this! May I ask if the output of lst.List(i).value is a string please?

[arnelgp]

Many thanks for this! May I ask if the output of lst.List(i).value is a string please?
yes, it contains all the file (path+file) found.

[snb]

I'd use:


Sub M_snb()
msgbox createobject("wscript.shell").exec("cmd /c dir ""F:\Petrography Images\*Mosaix.zvi"" /b /s").stdout.readall
End Sub

[Trex_tony]

worked like a charm, thank you!