Option Explicit
Global aryFoundFiles As Variant
Sub PopulateListBoxWithFiles()
'Searches I:\IsolationDataBase\IsolationProcedures for filename.ext pattern (wildcards OK) in cell A1
'If no pattern in A1 then *.* is used to return all files.
'Add reference to Microsoft Scripting Runtime (VBA editor: Tools | References)
'Calls ReturnFilePathNameArray
Dim aryFilenames() As Variant
Dim strFileName As String
Dim strPath As String
Dim booSame As Boolean
Dim intX As Integer
Dim intY As Integer
Dim strFileDirectory As String
Dim strSort1 As String
Dim strSort2 As String
strFileDirectory = "I:\IsolationDataBase\IsolationProcedures"
strFileName = Range("A1").Value
'Select Directory - "Uncomment section below to allow a directory to be chosen at runtime
' With Application.FileDialog(msoFileDialogFolderPicker)
' .Title = "Select the directory"
' .AllowMultiSelect = False
' .ButtonName = "Select"
' .InitialFileName = ThisWorkbook.Path
' .Show
' If .SelectedItems.Count > 0 Then
' strFileDirectory = .SelectedItems.Item(1)
' End If
' End With
'Verify the A1 value is the desired filename
strFileName = InputBox("Enter the filename or pattern (wildcards OK) to search for", "Search for", "*.*")
'Next code line checks for existance of filename and defaults to *.* if it is not present
'more checks should be added to ensure only valid filenames are used.
If strFileName = "" Then strFileName = "*.*"
UserForm1.ListBox1.Clear
ReturnFilePathNameArray strFileDirectory, strFileName
If Len(aryFoundFiles(1)) = 0 Then
'Do nothing - error msgbox was displayed by 'ReturnFilePathNameArray' procedure
Else
aryFilenames = aryFoundFiles
'Sort array
For intX = 1 To UBound(aryFilenames)
For intY = intX To UBound(aryFilenames)
If UCase(aryFilenames(intY)) < UCase(aryFilenames(intX)) Then
strSort1 = aryFilenames(intX)
strSort2 = aryFilenames(intY)
aryFilenames(intX) = strSort2
aryFilenames(intY) = strSort1
End If
Next intY
Next intX
booSame = True
strPath = Left(aryFilenames(1), InStrRev(aryFilenames(1), "\"))
For intX = 2 To UBound(aryFilenames)
If strPath <> Left(aryFilenames(intX), InStrRev(aryFilenames(intX), "\")) Then
booSame = False
Exit For
End If
Next
If booSame Then 'All files returned are in the same directory
UserForm1.ListBox2.List = Array(strPath) 'Display common path in listbox2
'Remove path from aryFilenames
For intX = 1 To UBound(aryFilenames)
aryFilenames(intX) = Mid(aryFilenames(intX), InStrRev(aryFilenames(intX), "\") + 1, 100)
Next
Else
UserForm1.ListBox2.List = Array("Multiple Directories Returned (" & UBound(aryFilenames) & ") files.")
End If
UserForm1.ListBox1.List = aryFilenames()
UserForm1.Show (vbModeless)
End If
End_Sub:
End Sub
Sub ReturnFilePathNameArray(strPath As String, strFileLike As String)
'Calls GetFiles
Dim fso As FileSystemObject 'Add reference to Microsoft Scripting Runtime
ReDim aryFoundFiles(1 To 1)
Set fso = CreateObject("Scripting.FileSystemObject")
GetFiles fso, strPath, strFileLike
If UBound(aryFoundFiles) = 1 Then
MsgBox "No files were returned for this starting directory: " & strPath & vbLf & _
"and this file pattern: " & strFileLike
Else
ReDim Preserve aryFoundFiles(1 To UBound(aryFoundFiles) - 1)
End If
Set fso = Nothing
End Sub
Sub GetFiles(fso As FileSystemObject, strPath As String, strFilePattern As String)
Dim fldr As Folder
Dim fldrSub As Folder
Dim oFile As Object
Set fldr = fso.GetFolder(strPath)
If fldr.Files.Count > 0 Then
For Each oFile In fldr.Files
If UCase(oFile.Name) Like UCase(strFilePattern) Then 'UCase makes search case insensitive
aryFoundFiles(UBound(aryFoundFiles)) = oFile.Path
ReDim Preserve aryFoundFiles(1 To UBound(aryFoundFiles) + 1)
End If
Next
End If
If fldr.SubFolders.Count > 0 Then
For Each fldrSub In fldr.SubFolders
GetFiles fso, fldrSub.Path, strFilePattern
Next
End If
Set fldr = Nothing
End Sub
