List files in a folder with Microsoft Scripting Runtime

 2000-02-04    Files & Folders    0    370

Microsoft Scripting Runtime is included in these products: Windows98, Windows2000, IE5, and Office2000. The macro examples below assumes that your VBA project has added a reference to the Microsoft Scripting Runtime library. You can do this from within the VBE by selecting the menu Tools, References... and selecting the Microsoft Scripting Runtime library.

Sub TestListFilesInFolder()
    Workbooks.Add ' create a new workbook for the file list
    ' add headers
    With Range("A1")
        .Formula = "Folder contents:"
        .Font.Bold = True
        .Font.Size = 12
    End With
    Range("A3").Formula = "File Name:"
    Range("B3").Formula = "File Size:"
    Range("C3").Formula = "File Type:"
    Range("D3").Formula = "Date Created:"
    Range("E3").Formula = "Date Last Accessed:"
    Range("F3").Formula = "Date Last Modified:"
    Range("G3").Formula = "Attributes:"
    Range("H3").Formula = "Short File Name:"
    Range("A3:H3").Font.Bold = True
    ListFilesInFolder "C:\FolderName" ' all files in folder
    'ListFilesInFolder "C:\FolderName", "*.*", True ' all files, included subfolders
    'ListFilesInFolder "C:\FolderName", "*.xl*", True ' all Excel files, included subfolders
End Sub

Sub ListFilesInFolder(SourceFolderName As String, Optional FileFilter As String = "*.*", _
    Optional IncludeSubfolders As Boolean = False)
' lists information about the files in SourceFolder
' example: ListFilesInFolder "C:\FolderName", "*.xl*", True
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.File, r As Long
    If Len(FileFilter) = 0 Then FileFilter = "*.*"
    Set FSO = New Scripting.FileSystemObject
    On Error Resume Next
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    On Error GoTo 0
    If Not SourceFolder Is Nothing Then
        r = Range("A65536").End(xlUp).Row
        For Each FileItem In SourceFolder.Files
            If FileItem.Name Like FileFilter Then
                ' display file properties
                r = r + 1 ' next row number
                Cells(r, 1).Formula = FileItem.Path & FileItem.Name
                Cells(r, 2).Formula = FileItem.Size
                Cells(r, 3).Formula = FileItem.Type
                Cells(r, 4).Formula = FileItem.DateCreated
                Cells(r, 5).Formula = FileItem.DateLastAccessed
                Cells(r, 6).Formula = FileItem.DateLastModified
                Cells(r, 7).Formula = FileItem.Attributes
                Cells(r, 8).Formula = FileItem.ShortPath & FileItem.ShortName
                ' use file methods (not proper in this example)
        '        FileItem.Copy "C:\FolderName\Filename.txt", True
        '        FileItem.Move "C:\FolderName\Filename.txt"
        '        FileItem.Delete True
            End If
        Next FileItem
        If IncludeSubfolders Then
            For Each SubFolder In SourceFolder.SubFolders
                ListFilesInFolder SubFolder.Path, True
            Next SubFolder
        End If
        Columns("A:H").AutoFit
        Set FileItem = Nothing
        Set SourceFolder = Nothing
    End If
    Set FSO = Nothing
    ActiveWorkbook.Saved = True
End Sub