20140521-程式-透過VBA取得目錄&子目錄的列表

找到一些資源做個記錄一下：

參考文章：http://goo.gl/GCMR5k

(我是採用 royUK 的VBA，它可以透過GUI選目錄)

1. 開Excel ,用 「Alt + F11 」開啟VBA


2. Insert > Module  ，建立 「註一」「註二」的 Script 。

3. 要參考「Microsoft Scripting Runtime library」
    Tools > References

4. 按Run 即可產生 清單列表：


5. 這就是我Run出來的結果

--------
我將VBA 改了一小部份，以讓它可以決定取的「深度」
--------


註一：

VB:

Const BIF_RETURNONLYFSDIRS As Long = &H1 ''' For finding a folder to start document searching
Const BIF_DONTGOBELOWDOMAIN As Long = &H2 ''' Does not include network folders below the domain level in the tree view control
Const BIF_RETURNFSANCESTORS As Long = &H8 ''' Returns only file system ancestors.
Const BIF_BROWSEFORCOMPUTER As Long = &H1000 ''' Returns only computers.
Const BIF_BROWSEFORPRINTER As Long = &H2000 ''' Returns only printers.
Const BIF_BROWSEINCLUDEFILES As Long = &H4000 ''' Returns everything.
 
Const MAX_PATH As Long = 260 
 
Type BROWSEINFO 
    hOwner     As Long 
    pidlRoot   As Long 
    pszDisplayName As String 
    lpszINSTRUCTIONS As String 
    ulFlags    As Long 
    lpfn       As Long 
    lParam     As Long 
    iImage     As Long 
End Type 
 
Declare Function SHGetPathFromIDListA Lib "shell32.dll" (ByVal pidl As Long, ByVal pszBuffer As String) As Long 
Declare Function SHBrowseForFolderA Lib "shell32.dll" (lpBrowseInfo As BROWSEINFO) As Long 
 
 
Function BrowseFolder() As String 
     
    Const szINSTRUCTIONS As String = "Choose the folder to use for this operation." & vbNullChar 
     
    Dim uBrowseInfo As BROWSEINFO 
    Dim szBuffer As String 
    Dim lID    As Long 
    Dim lRet   As Long 
     
    With uBrowseInfo 
        .hOwner = 0 
        .pidlRoot = 0 
        .pszDisplayName = String$(MAX_PATH, vbNullChar) 
        .lpszINSTRUCTIONS = szINSTRUCTIONS 
        .ulFlags = BIF_RETURNONLYFSDIRS 
        .lpfn = 0 
    End With 
     
    szBuffer = String$(MAX_PATH, vbNullChar) 
     
     ''' Show the browse dialog.
    lID = SHBrowseForFolderA(uBrowseInfo) 
     
    If lID Then 
         ''' Retrieve the path string.
        lRet = SHGetPathFromIDListA(lID, szBuffer) 
        If lRet Then BrowseFolder = Left$(szBuffer, InStr(szBuffer, vbNullChar) - 1) 
    End If 
     
End Function 

註二：

VB:
Option Explicit 
 
Sub CreateList() 
    Application.ScreenUpdating = False 
    Workbooks.Add ' create a new workbook for the folder list
     ' add headers
    With Cells(1, 1) 
        .Value = "Folder contents:" 
        .Font.Bold = True 
        .Font.Size = 12 
    End With 
    Cells(3, 1).Value = "Folder Path:" 
    Cells(3, 2).Value = "Folder Name:" 
    Cells(3, 3).Value = "Size:" 
    Cells(3, 4).Value = "Subfolders:" 
    Cells(3, 5).Value = "Files:" 
    Cells(3, 6).Value = "Short Name:" 
    Cells(3, 7).Value = "Short Path:" 
    Range("A3:G3").Font.Bold = True 
    ListFolders BrowseFolder, True, 2
    Application.ScreenUpdating = True 
End Sub 
 

'加上深度的資訊
Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean, Deep As Integer)
     ' lists information about the folders in SourceFolder
    Dim FSO    As Scripting.FileSystemObject 
    Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder 
    Dim r      As Long 
    Set FSO = New Scripting.FileSystemObject 
    Set SourceFolder = FSO.GetFolder(SourceFolderName) 
     ' display folder properties
    r = Cells(Rows.Count, 1).End(xlUp).Row + 1 
    Cells(r, 1).Value = SourceFolder.Path 
    Cells(r, 2).Value = SourceFolder.Name 
    Cells(r, 3).Value = SourceFolder.Size 
    Cells(r, 4).Value = SourceFolder.SubFolders.Count 
    Cells(r, 5).Value = SourceFolder.Files.Count 
    Cells(r, 6).Value = SourceFolder.ShortName 
    Cells(r, 7).Value = SourceFolder.ShortPath 
    If IncludeSubfolders Then 
        For Each SubFolder In SourceFolder.SubFolders 
            If Deep > 0 Then
                ListFolders SubFolder.Path, True, Deep - 1
                End If

        Next SubFolder 
        Set SubFolder = Nothing 
    End If 
    Columns("A:G").AutoFit 
    Set SourceFolder = Nothing 
    Set FSO = Nothing 
    ActiveWorkbook.Saved = True 
     
End Sub