Replacement solution including searching in subdirectories

[Pav Habr]

'!!! Replacement solution including searching in subdirectories !!!!


//----------------------------------------------------------------------
--------------------------

Sub FileSearchByHavrda_Example_of_procedure_calling()
'
' Example of FileSearchByHavrda procedure calling as replacement of
missing FileSearch function in the newest MS Office VBA
' 01.06.2009, Author: P. Havrda, Czech Republic
'

Dim FileNameWithPath As Variant
Dim ListOfFilenamesWithParh As New Collection ' create a collection
of filenames

' Filling a collection of filenames (search Excel files including
subdirectories)
Call FileSearchByHavrda(ListOfFilenamesWithParh, "C:\Temp", "*.xls",
True)

' Print list to immediate debug window and as a message window
For Each FileNameWithPath In ListOfFilenamesWithParh ' cycle for
list(collection) processing
Debug.Print FileNameWithPath & Chr(13)
MsgBox FileNameWithPath & Chr(13)
Next FileNameWithPath

' Print to immediate debug window and message if no file was found
If ListOfFilenamesWithParh.Count = 0 Then
Debug.Print "No file was found !"
MsgBox "No file was found !"
End If

End Sub

//----------------------------------------------------------------------
--------------------------

Private Sub FileSearchByHavrda(pFoundFiles As Collection, pPath As
String, pMask As String, pIncludeSubdirectories As Boolean)
'
' Search files in Path and create FoundFiles list(collection) of file
names(path included) accordant with Mask (search in subdirectories if
enabled)
' 01.06.2009, Author: P. Havrda, Czech Republic
'

Dim DirFile As String
Dim CollectionItem As Variant
Dim SubDirCollection As New Collection

' Add backslash at the end of path if not present
pPath = Trim(pPath)
If Right(pPath, 1) <> "\" Then pPath = pPath & "\"

' Searching files accordant with mask
DirFile = Dir(pPath & pMask)
Do While DirFile <> ""
pFoundFiles.Add pPath & DirFile 'add file name to list(collection)
DirFile = Dir ' next file
Loop

' Procedure exiting if searching in subdirectories isn't enabled
If Not pIncludeSubdirectories Then Exit Sub

' Searching for subdirectories in path
DirFile = Dir(pPath & "*", vbDirectory)
Do While DirFile <> ""
' Add subdirectory to local list(collection) of subdirectories in
path
If DirFile <> "." And DirFile <> ".." Then If ((GetAttr(pPath &
DirFile) And vbDirectory) = 16) Then SubDirCollection.Add pPath &
DirFile
DirFile = Dir 'next file
Loop

' Subdirectories list(collection) processing
For Each CollectionItem In SubDirCollection
Call FileSearchByHavrda(pFoundFiles, CStr(CollectionItem), pMask,
pIncludeSubdirectories) ' Recursive procedure call
Next

End Sub

//----------------------------------------------------------------------