Retrieving filenames from a folder

 2011-10-29    Files & Folders    0    134

Sometimes you don't need to ask the user to select a list of files that you want to do something with. If you already know the source folder and types of files you want to retrieve you can use the function below. This function is also a simple replacement for the Application.FileSearch that is not longer supported by Excel.

Function GetFilesFromFolder(ByVal FolderPath As String, ByVal FileFilter As String) As Collection
' returns a collection of filenames from a folder where the filenames matches the file filter
' the returned filenames will probably not be in alphabetical order
Dim strFile As String
    If Len(FolderPath) < 3 Then Exit Function
    If Right(FolderPath, 1) <> Application.PathSeparator Then
        FolderPath = FolderPath & Application.PathSeparator
    End If
    If Len(FileFilter) < 3 Then FileFilter = "*.*"
    
    Set GetFilesFromFolder = New Collection
    On Error Resume Next
    strFile = Dir(FolderPath & FileFilter) ' first matching file in folder
    On Error GoTo 0
    Do While Len(strFile) > 0
        GetFilesFromFolder.Add FolderPath & strFile
        strFile = Dir ' next matching file in folder
    Loop
    If GetFilesFromFolder.Count = 0 Then Set GetFilesFromFolder = Nothing
End Function
 
Sub TestGetFilesFromFolder()
Dim coll As Collection, r As Long
    Set coll = GetFilesFromFolder("C:\FolderName", "*.*")
    If coll Is Nothing Then Exit Sub
    
    Application.StatusBar = "Listing result, " & coll.Count & " files..."
    Workbooks.Add
    For r = 1 To coll.Count
        Range("A" & r).Formula = coll(r)
    Next r
    Set coll = Nothing
    Application.StatusBar = False
End Sub
The function above is somewhat limited since it does not support retrieving filenames from subfolders, and the filenames returned are probably not in alphabetical order. If you want this type of functionality you can use the macros below.
Function FileSearch(ByVal InitialFolder As String, ByVal FileFilter As String, Optional InclSubFolders As Boolean = False) As Variant
' returns an array with filenames from FolderPath where the filenames matches FileFilter
' can include subfolders too
Dim coll As Collection
    FileSearch = False
    GetFolderFiles coll, InitialFolder, FileFilter, InclSubFolders
    If Not coll Is Nothing Then
        Application.StatusBar = "Sorting file search result, " & coll.Count & " files..."
        FileSearch = Coll2Array(coll, True)
        Application.StatusBar = False
    End If
End Function

Sub GetFolderFiles(ByRef coll As Collection, ByVal FolderPath As String, ByVal FileFilter As String, Optional InclSubFolders As Boolean = False)
' adds filenames to coll from FolderPath where the filenames matches FileFilter
' can include subfolders too
Dim fso As Scripting.FileSystemObject, objFolder As Scripting.Folder, objSubFolder As Scripting.Folder, objFile As Scripting.File
    If Len(FolderPath) < 3 Then FolderPath = CurDir
    If Right(FolderPath, 1) <> Application.PathSeparator Then
        FolderPath = FolderPath & Application.PathSeparator
    End If
    If Len(FileFilter) < 3 Then FileFilter = "*.*" ' all files
    FileFilter = LCase(FileFilter) ' not case sensitive name compare
    
    On Error Resume Next
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set objFolder = fso.GetFolder(FolderPath)
    On Error GoTo 0
    If Not objFolder Is Nothing Then
        If InclSubFolders Then
            For Each objSubFolder In objFolder.SubFolders
                GetFolderFiles coll, objSubFolder.Path, FileFilter, True
            Next objSubFolder
            Set objSubFolder = Nothing
        End If
        
        Application.StatusBar = "Searching for files: " & objFolder.Path & Application.PathSeparator & FileFilter
        If coll Is Nothing Then Set coll = New Collection
        For Each objFile In objFolder.Files
            If LCase(objFile.Name) Like FileFilter Then ' not case sensitive name compare
                coll.Add objFile.Path
            End If
        Next objFile
        Set objFile = Nothing
    End If
    Set fso = Nothing
    Application.StatusBar = False
    If coll.Count = 0 Then Set coll = Nothing
End Sub

Function Coll2Array(coll As Collection, Optional blnSort As Boolean = False, Optional blnBinaryCompare As Boolean = False) As Variant
Dim arrItems() As String, i As Long, j As Long, strTemp As String
    Coll2Array = False
    If coll Is Nothing Then Exit Function
    If coll.Count = 0 Then Exit Function
    
    ReDim arrItems(0 To coll.Count - 1)
    For i = 1 To coll.Count
        arrItems(i - 1) = coll(i)
    Next i
    
    If blnSort And coll.Count > 1 Then
        For i = LBound(arrItems) To UBound(arrItems) - 1
            For j = i + 1 To UBound(arrItems)
                If blnBinaryCompare Then
                    If arrItems(i) > arrItems(j) Then
                        strTemp = arrItems(i)
                        arrItems(i) = arrItems(j)
                        arrItems(j) = strTemp
                    End If
                Else ' not case sensitive comparare
                    If LCase(arrItems(i)) > LCase(arrItems(j)) Then
                        strTemp = arrItems(i)
                        arrItems(i) = arrItems(j)
                        arrItems(j) = strTemp
                    End If
                End If
            Next j
        Next i
    End If
    Coll2Array = arrItems
End Function

Sub TestFileSearch()
Dim varItems As Variant, i As Long, r As Long
    varItems = FileSearch("C:\FolderName", "*.*", True)
    If Not IsArray(varItems) Then Exit Sub
    
    Application.StatusBar = "Listing result, " & UBound(varItems) + 1 & " files..."
    Workbooks.Add
    r = 0
    For i = LBound(varItems) To UBound(varItems)
        r = r + 1
        Range("A" & r).Formula = varItems(i)
    Next i
    Erase varItems
    Application.StatusBar = False
End Sub


Leave a comment:

Your comment will only be published after it has been moderated and found spam free.
Your e-mail address will only be used to display your Gravatar.