excelvbafunctionfilefilesystemobject

Get file names from folder and subfolder function change


i have this code below to get files names from a specific folder and it works great. i like how is transposes the file names it works really well with how i do my work.

what i want to change is to have it also return the file names with in the subfolders to. but carry on transposing it accrss my work sheet.

Thank you.

Function GetFileNames6(ByVal FolderPath As String) As Variant
Dim Result As Variant
Dim i As Integer
Dim MyFile As Object
Dim MyFSO As Object
Dim myFolder As Object
Dim MyFiles As Object
Set MyFSO = CreateObject("Scripting.FileSystemObject")
Set myFolder = MyFSO.GetFolder(FolderPath)
Set MyFiles = myFolder.Files
ReDim Result(1 To MyFiles.Count)
i = 1
o = 1
For Each MyFile In MyFiles
Result(i) = MyFile.name & " " & MyFile.DateCreated
i = i + 1

Next MyFile
GetFileNames6 = Result

End Function

Solution

  • Return File Names From All Folders and Subfolders

    Issues

    Option Explicit
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Purpose:      Tests the 'GetFileNames6' function.
    ' Calls:        GetFileNames6
    '                   ArrFilePaths
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Sub GetFileNames6TEST()
        
        Const FolderPath As String = "C:\Test\"
         
        Dim NamesDates() As String: NamesDates = GetFileNames6(FolderPath)
        
        If UBound(NamesDates) = -1 Then
            Debug.Print "No files found."
            Exit Sub
        End If
        
        Debug.Print Join(NamesDates, vbLf)
       
    End Sub
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Purpose:      Returns a zero-based string array containing the concatenated
    '               names and dates ('DateCreated') from a given zero-based string
    '               array containing file paths.
    ' Calls:        ArrFilePaths.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Function GetFileNames6( _
        ByVal FolderPath As String, _
        Optional ByVal Delimiter As String = " ") _
    As String()
        Const ProcName As String = "GetFileNames6"
        On Error GoTo ClearError
        
        ' Ensuring that a string array is passed if an error occurs.
        GetFileNames6 = Split("") ' LB = 0 , UB = -1
        
        Dim FilePaths() As String: FilePaths = ArrFilePaths(FolderPath)
        'Debug.Print Join(FilePaths, vbLf)
        
        Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
        
        Dim fsoFile As Object
        Dim n As Long ' Files Count
        Dim fCount As Long ' Found Files Count
        
        For n = 0 To UBound(FilePaths)
            If fso.FileExists(FilePaths(n)) Then
                Set fsoFile = fso.GetFile(FilePaths(n))
                FilePaths(fCount) = fsoFile.Name & Delimiter & fsoFile.DateCreated
                fCount = fCount + 1
            Else ' happens if not 'standard characters' (character map?)
                Debug.Print "Not found:             " & FilePaths(n)
            End If
        Next n
            
        If fCount < n Then
            ReDim Preserve FilePaths(0 To fCount - 1)
            'Debug.Print Join(FilePaths, vbLf)
            Debug.Print "Initially found files: " & n
            Debug.Print "Finally found files:   " & fCount
        End If
            
        GetFileNames6 = FilePaths
    
    ProcExit:
        Exit Function
    ClearError:
        Debug.Print "'" & ProcName & "' Run-time error '" _
            & Err.Number & "':" & vbLf & "    " & Err.Description
        Resume ProcExit
    End Function
    
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Purpose:      Returns the file paths of the files in a folder in an array.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Function ArrFilePaths( _
        ByVal FolderPath As String, _
        Optional ByVal FilePattern As String = "*.*", _
        Optional ByVal DirSwitches As String = "/s/b/a-d") _
    As String()
        Const ProcName As String = "ArrFilePaths"
        On Error GoTo ClearError
        
        ' Ensuring that a string array is passed if an error occurs.
        ArrFilePaths = Split("") ' LB = 0 , UB = -1
       
        Dim pSep As String: pSep = Application.PathSeparator
        If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
        Dim ExecString As String ' '%comspec%' or 'cmd.exe' ?
        ExecString = "%comspec% /c Dir """ _
            & FolderPath & FilePattern & """ " & DirSwitches
        Dim Arr() As String: Arr = Split(CreateObject("WScript.Shell") _
            .Exec(ExecString).StdOut.ReadAll, vbCrLf)
        If UBound(Arr) > 0 Then
            ReDim Preserve Arr(0 To UBound(Arr) - 1)
        End If
        ArrFilePaths = Arr
    
    ProcExit:
        Exit Function
    ClearError:
        Debug.Print "'" & ProcName & "' Run-time error '" _
            & Err.Number & "':" & vbLf & "    " & Err.Description
        Resume ProcExit
    End Function