Dunk

Sub 列出檔案相關資訊()
    Dim selectFolder As String
    Dim myFd As FileDialog
    Set myFd = Application.FileDialog(msoFileDialogFolderPicker)  '[選擇檔案]
        With myFd
        .Title = "請選擇資料夾路徑"
        .ButtonName = "確定"
        .InitialFileName = ThisWorkbook.Path & "\"
        If .Show = True Then            '顯示
            selectFolder = .SelectedItems(1)
        Else
            Call 設定標題(1)
            Call 設定標題(2)
            MsgBox "已取消"
            Exit Sub
        End If
    End With
    
    Application.ScreenUpdating = False
    Call 列出檔案清單(selectFolder)
    Call 列出子目錄清單(selectFolder)
    MsgBox "列出檔案資訊完畢!"
    Application.ScreenUpdating = True
End Sub


Sub 設定標題(ByVal sheetIndex As Integer)
    '清除內容並將將儲存格格式設為文字格式
    Dim pt As Range
    Dim myRange As Range
    Dim i As Integer
    Set pt = ThisWorkbook.Sheets(sheetIndex).Range("a2")
    For i = 1 To 3
        pt.Worksheet.Columns(i).ClearContents
    Next
    Set myRange = ThisWorkbook.Sheets(sheetIndex).Range("A1:C65536")
    myRange.NumberFormatLocal = "@"
            
    '設定標題
    ThisWorkbook.Sheets(sheetIndex).Range("A1").Value = "路徑"
    ThisWorkbook.Sheets(sheetIndex).Range("B1").Value = "大小"
    ThisWorkbook.Sheets(sheetIndex).Range("C1").Value = "修改時間"
End Sub

Sub 列出檔案清單(ByVal theDir As String)
    Dim pt As Range
                
    Set pt = Sheet1.Range("a2")
    Call 設定標題(1)
                
    If Len(Dir(theDir, vbDirectory)) > 0 Then
        If (GetAttr(theDir) And vbDirectory) = vbDirectory Then
            Call FileIOUtility.RetrivalFileList(theDir, pt, 0)
        End If
    End If
    
    pt.Worksheet.Columns("A:B").AutoFit
End Sub

Sub 列出子目錄清單(ByVal theDir As String)
    Dim pt As Range
                    
    Set pt = Sheet2.Range("a2")
    Call 設定標題(2)
    
    If Len(Dir(theDir, vbDirectory)) > 0 Then
        If (GetAttr(theDir) And vbDirectory) = vbDirectory Then
            Call FileIOUtility.RetrivalAllSubFolderList(theDir, pt)
        End If
    End If
    
    pt.Worksheet.Columns("A:B").AutoFit
End Sub

'列出檔案清單
'depth=0
Function RetrivalFileList(ByVal strDir As String, ByRef myRange As Range, ByRef depth As Integer)
    Dim thePath As String
    Dim strSdir As String
    Dim theDirs As Scripting.Folders
    Dim theDir As Scripting.Folder
    Dim theFile As Scripting.File
    Dim myFso As Scripting.FileSystemObject
    Dim subFolderCount As Integer
    
    Set myFso = New Scripting.FileSystemObject
    If Right(strDir, 1) <> "" Then strDir = strDir & ""
    thePath = thePath & strDir
        
    '列出第一層根目錄的檔案
    If depth = 0 Then
            For Each theFile In myFso.getfolder(strDir).Files
                myRange = theFile.Path
                myRange.Next = theFile.Size
                myRange.Next.Next = theFile.DateLastModified
                Set myRange = myRange.Offset(1, 0)
            Next
            depth = 1
    End If
        
    '尋找所有子目錄的檔案
    Set theDirs = myFso.getfolder(strDir).SubFolders
    For Each theDir In theDirs
        For Each theFile In theDir.Files
            myRange = theFile.Path
            myRange.Next = theFile.Size
            myRange.Next.Next = theFile.DateLastModified
            Set myRange = myRange.Offset(1, 0)
        Next
        RetrivalFileList strDir:=theDir.Path, myRange:=myRange, depth:=depth
    Next
    Set myFso = Nothing
End Function


'列出所有子目錄名稱大小及最後修改日期
Function RetrivalAllSubFolderList(ByVal strDir As String, ByRef myRange As Range)
    Dim thePath As String
    Dim strSdir As String
    Dim theDirs As Scripting.Folders
    Dim theDir As Scripting.Folder
    Dim theFile As Scripting.File
    Dim myFso As Scripting.FileSystemObject
    Dim subFolderCount As Integer
    
    Set myFso = New Scripting.FileSystemObject
    If Right(strDir, 1) <> "" Then strDir = strDir & ""
    thePath = thePath & strDir
                  
    '尋找所有子目錄
    Set theDirs = myFso.getfolder(strDir).SubFolders
    For Each theDir In theDirs
        myRange = theDir.Path
        myRange.Next = theDir.Size
        myRange.Next.Next = theDir.DateLastModified
        Set myRange = myRange.Offset(1, 0)
        RetrivalAllSubFolderList strDir:=theDir.Path, myRange:=myRange
    Next
    Set myFso = Nothing
End Function

Private Sub CommandButton1_Click()
    Call FileInfo.列出檔案相關資訊
End Sub