獲取vba中的子​​目錄列表

Question

• 我想獲取文件夾中所有子目錄的列表。
• 如果這有效，我想將其擴展爲遞歸函數。

但是，我最初的方法來獲取subdirs失敗。它只是顯示包括文件在內的所有內容：

sDir = Dir(sPath, vbDirectory) 
Do Until LenB(sDir) = 0 
    Debug.Print sDir 
    sDir = Dir 
Loop 

該列表以'..'和多個文件夾開始，以'.txt'文件結尾。

編輯： 我要補充一點，必須在Word中運行，而不是Excel文件（許多功能在Word中可用），它是Office 2010的

編輯2：

一個可以確定的類型使用

iAtt = GetAttr(sPath & sDir) 
If CBool(iAtt And vbDirectory) Then 
    ... 
End If 

但結果這給了我新的問題，所以，我現在使用基於Scripting.FileSystemObject代碼。

Answer 1

更新2014年7月：新增PowerShell選項，並削減了第二碼列出文件夾只

下面的方法運行完整的遞歸過程，而不是在Office 2007中棄用的FileSearch。（後兩個代碼僅使用Excel作爲輸出 - 此輸出可以在Word中運行時刪除）

1. 殼牌PowerShell
2. 與Dir使用FSO用於過濾文件類型。源自這個位於EE收費牆背後的EE answer。這比您要求的長度（文件夾列表）長，但我認爲它很有用，因爲它可以讓您得到一系列結果，以便與
3. 使用Dir進一步協同工作。這個例子來自我的答案我提供在其他網站上

1.使用PowerShell傾倒C以下的所有文件夾：\ TEMP成csv文件

Sub Comesfast() 
X2 = Shell("powershell.exe Get-ChildItem c:\temp -Recurse | ?{ $_.PSIsContainer } | export-csv C:\temp\filename.csv", 1) 
End Sub 

2。使用FileScriptingObject傾倒C以下的所有文件夾：\ TEMP到Excel

Public Arr() As String 
Public Counter As Long 

Sub LoopThroughFilePaths() 
Dim myArr 
Dim strPath As String 
strPath = "c:\temp\" 
myArr = GetSubFolders(strPath) 
[A1].Resize(UBound(myArr, 1), 1) = Application.Transpose(myArr) 
End Sub 


Function GetSubFolders(RootPath As String) 
Dim fso As Object 
Dim fld As Object 
Dim sf As Object 
Dim myArr 

Set fso = CreateObject("Scripting.FileSystemObject") 
Set fld = fso.GetFolder(RootPath) 
For Each sf In fld.SUBFOLDERS 
    ReDim Preserve Arr(Counter) 
    Arr(Counter) = sf.Path 
    Counter = Counter + 1 
    myArr = GetSubFolders(sf.Path) 
Next 
GetSubFolders = Arr 
Set sf = Nothing 
Set fld = Nothing 
Set fso = Nothing 
End Function 

3使用Dir

Option Explicit 

    Public StrArray() 
    Public lngCnt As Long 
    Public b_OS_XP As Boolean 

    Public Enum MP3Tags 
    ' See http://www.kixtart.org/forums/ubbthreads.php?ubb=showflat&Number=160880&page=1 for OS specific attribute lists 
    XP_Artist = 16 
    XP_AlbumTitle = 17 
    XP_SongTitle = 10 
    XP_TrackNumber = 19 
    XP_RecordingYear = 18 
    XP_Genre = 20 
    XP_Duration = 21 
    XP_BitRate = 22 
    Vista_W7_Artist = 13 
    Vista_W7_AlbumTitle = 14 
    Vista_W7_SongTitle = 21 
    Vista_W7_TrackNumber = 26 
    Vista_W7_RecordingYear = 15 
    Vista_W7_Genre = 16 
    Vista_W7_Duration = 17 
    Vista_W7_BitRate = 28 
    End Enum 

    Public Sub Main() 
    Dim objws 
    Dim objWMIService 
    Dim colOperatingSystems 
    Dim objOperatingSystem 
    Dim objFSO 
    Dim objFolder 
    Dim Wb As Workbook 
    Dim ws As Worksheet 
    Dim strobjFolderPath As String 
    Dim strOS As String 
    Dim strMyDoc As String 
    Dim strComputer As String 

    'Setup Application for the user 
    With Application 
     .ScreenUpdating = False 
     .DisplayAlerts = False 
    End With  

    'reset public variables 
    lngCnt = 0 
    ReDim StrArray(1 To 10, 1 To 1000) 

    ' Use wscript to automatically locate the My Documents directory 
    Set objws = CreateObject("wscript.shell") 
    strMyDoc = objws.SpecialFolders("MyDocuments") 


    strComputer = "." 
    Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2") 
    Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem") 
    For Each objOperatingSystem In colOperatingSystems 
     strOS = objOperatingSystem.Caption 
    Next 

    Set objFSO = CreateObject("Scripting.FileSystemObject") 
    If InStr(strOS, "XP") Then 
     b_OS_XP = True 
    Else 
     b_OS_XP = False 
    End If 


    ' Format output sheet 
    Set Wb = Workbooks.Add(1) 
    Set ws = Wb.Worksheets(1) 
    ws.[a1] = Now() 
    ws.[a2] = strOS 
    ws.[a3] = strMyDoc 
    ws.[a1:a3].HorizontalAlignment = xlLeft 

    ws.[A4:J4].Value = Array("Folder", "File", "Artist", "Album Title", "Song Title", "Track Number", "Recording Year", "Genre", "Duration", "Bit Rate") 
    ws.Range([a1], [j4]).Font.Bold = True 
    ws.Rows(5).Select 
    ActiveWindow.FreezePanes = True 


    Set objFSO = CreateObject("Scripting.FileSystemObject") 
    Set objFolder = objFSO.GetFolder(strMyDoc) 

    ' Start the code to gather the files 
    ShowSubFolders objFolder, True 
    ShowSubFolders objFolder, False 

    If lngCnt > 0 Then 
     ' Finalise output 
     With ws.Range(ws.[a5], ws.Cells(5 + lngCnt - 1, 10)) 
      .Value2 = Application.Transpose(StrArray) 
      .Offset(-1, 0).Resize(Rows.Count - 3, 10).AutoFilter 
      .Offset(-4, 0).Resize(Rows.Count, 10).Columns.AutoFit 
     End With 
     ws.[a1].Activate 
    Else 
     MsgBox "No files found!", vbCritical 
     Wb.Close False 
    End If 

    ' tidy up 

    Set objFSO = Nothing 
    Set objws = Nothing 

    With Application 
     .ScreenUpdating = True 
     .DisplayAlerts = True 
     .StatusBar = vbNullString 
    End With 
    End Sub 

    Sub ShowSubFolders(ByVal objFolder, bRootFolder As Boolean) 
    Dim objShell 
    Dim objShellFolder 
    Dim objShellFolderItem 
    Dim colFolders 
    Dim objSubfolder 


    'strName must be a variant, as ParseName does not work with a string argument 
    Dim strFname 
    Set objShell = CreateObject("Shell.Application") 
    Set colFolders = objFolder.SubFolders 
    Application.StatusBar = "Processing " & objFolder.Path 

    If bRootFolder Then 
     Set objSubfolder = objFolder 
     GoTo OneTimeRoot 
    End If 

    For Each objSubfolder In colFolders 
     'check to see if root directory files are to be processed 
    OneTimeRoot: 
     strFname = Dir(objSubfolder.Path & "\*.mp3") 
     Set objShellFolder = objShell.Namespace(objSubfolder.Path) 
     Do While Len(strFname) > 0 
      lngCnt = lngCnt + 1 
      If lngCnt Mod 1000 = 0 Then ReDim Preserve StrArray(1 To 10, 1 To (lngCnt + 1000)) 
      Set objShellFolderItem = objShellFolder.ParseName(strFname) 
      StrArray(1, lngCnt) = objSubfolder 
      StrArray(2, lngCnt) = strFname 
      If b_OS_XP Then 
       StrArray(3, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_Artist) 
       StrArray(4, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_AlbumTitle) 
       StrArray(5, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_SongTitle) 
       StrArray(6, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_TrackNumber) 
       StrArray(7, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_RecordingYear) 
       StrArray(8, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_Genre) 
       StrArray(9, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_Duration) 
       StrArray(10, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_BitRate) 
      Else 
       StrArray(3, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_Artist) 
       StrArray(4, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_AlbumTitle) 
       StrArray(5, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_SongTitle) 
       StrArray(6, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_TrackNumber) 
       StrArray(7, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_RecordingYear) 
       StrArray(8, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_Genre) 
       StrArray(9, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_Duration) 
       StrArray(10, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_BitRate) 
      End If 
      strFname = Dir 
     Loop 
     If bRootFolder Then 
      bRootFolder = False 
      Exit Sub 
     End If 
     ShowSubFolders objSubfolder, False 
    Next 
    End Sub 

Answer 2

你最好用FileSystemObject。我認爲。

要叫這個，你只需要，說： listfolders 「C：\數據」

Sub listfolders(startfolder) 
''Reference Windows Script Host Object Model 
''If you prefer, just Dim everything as Object 
''and use CreateObject("Scripting.FileSystemObject") 
Dim fs As New FileSystemObject 
Dim fl1 As Folder 
Dim fl2 As Folder 

Set fl1 = fs.GetFolder(startfolder) 

For Each fl2 In fl1.SubFolders 
    Debug.Print fl2.Path 
    listfolders fl2.Path 
Next 

End Sub 

Answer 3

這裏是不使用Scripting.FileSystemObject因爲我發現它緩慢和不可靠的簡單版本。特別是.Name方法，正在放緩一切。此外，我在Excel中測試了這一點，但我不認爲我使用的任何東西在Word中都不可用。

首先是一些功能：

此連接兩個字符串創建一個文件路徑，類似於蟒蛇os.path.join。不需要記住是否在路徑末尾加上了「\」。

Const sep as String = "\" 

Function pjoin(root_path As String, file_path As String) As String 
    If right(root_path, 1) = sep Then 
     pjoin = root_path & file_path 
    Else 
     pjoin = root_path & sep & file_path 
    End If 
End Function 

此創建的根目錄root_path

Function subItems(root_path As String, Optional pat As String = "*", _ 
        Optional vbtype As Integer = vbNormal) As Collection 
    Set subItems = New Collection 
    Dim sub_item As String 
    sub_item= Dir(pjoin(root_path, pat), vbtype) 
    While sub_item <> "" 
     subItems.Add (pjoin(root_path, sub_item)) 
     sub_item = Dir() 
    Wend 
End Function 

的子項的集合此目錄root_path這包括文件夾，然後刪除那些不從集合文件夾項目創建子項的集合。它可以有選擇地刪除那些討厭的.和..文件夾

Function subFolders(root_path As String, Optional pat As String = "", _ 
        Optional skipDots As Boolean = True) As Collection 
    Set subFolders = subItems(root_path, pat, vbDirectory) 
    If skipDots Then 
     Dim dot As String 
     Dim dotdot As String 
     dot = pjoin(root_path, ".") 
     dotdot = dot & "." 
     Do While subFolders.Item(1) = dot _ 
     Or subFolders.Item(1) = dotdot 
      subFolders.remove (1) 
      If subFolders.Count = 0 Then Exit Do 
     Loop 
    End If 
    For i = subFolders.Count To 1 Step -1 
     ' This comparison could be replaced by and `fileExists` function 
     If Dir(subFolders.Item(i), vbNormal) <> "" Then 
      subFolders.remove (i) 
     End If 
    Next i 
End Function 

最後是基於別人的功能從本網站所使用Scripting.FileSystemObject我還沒有做到與原之間的對比測試中遞歸搜索功能。如果我再次找到該帖子，我會將其鏈接。注意collec通過引用傳遞，因此創建一個新集合並調用該子集來填充它。通過vbType:=vbDirectory所有子文件夾。

Sub walk(root_path As String, ByRef collec as Collection, Optional pat As String = "*" _ 
     Optional vbType as Integer = vbNormal) 
    Dim subF as Collection 
    Dim subD as Collection 
    Set subF = subItems(root_path, pat, vbType) 
    For Each sub_file In subF 
     collec.Add sub_file 
    Next sub_file 
    Set subD = subFolders(root_path) 
    For Each sub_folder In subD 
     walk sub_folder , collec, pat, vbType 
    Next sub_folder 
End Sub 

Answer 4

這是一個VBA解決方案，不使用外部對象。

由於Dir()函數的限制，您需要一次獲取每個文件夾的全部內容，而不是使用遞歸算法進行爬網。

Function GetFilesIn(Folder As String) As Collection 
    Dim F As String 
    Set GetFilesIn = New Collection 
    F = Dir(Folder & "\*") 
    Do While F <> "" 
    GetFilesIn.Add F 
    F = Dir 
    Loop 
End Function 

Function GetFoldersIn(Folder As String) As Collection 
    Dim F As String 
    Set GetFoldersIn = New Collection 
    F = Dir(Folder & "\*", vbDirectory) 
    Do While F <> "" 
    If GetAttr(Folder & "\" & F) And vbDirectory Then GetFoldersIn.Add F 
    F = Dir 
    Loop 
End Function 

Sub Test() 
    Dim C As Collection, F 

    Debug.Print 
    Debug.Print "Files in C:\" 
    Set C = GetFilesIn("C:\") 
    For Each F In C 
    Debug.Print F 
    Next F 

    Debug.Print 
    Debug.Print "Folders in C:\" 
    Set C = GetFoldersIn("C:\") 
    For Each F In C 
    Debug.Print F 
    Next F 
End Sub 

編輯

這個版本挖成子文件夾，並返回，而不是返回剛纔的文件或文件夾名全路徑名。

不與整個C驅動器上運行測試！

Function GetFilesIn(Folder As String, Optional Recursive As Boolean = False) As Collection 
    Dim F As String 
    Set GetFilesIn = New Collection 
    F = Dir(Folder & "\*") 
    Do While F <> "" 
    GetFilesIn.Add JoinPaths(Folder, F) 
    F = Dir 
    Loop 

    If Recursive Then 
    Dim SubFolder, SubFile 
    For Each SubFolder In GetFoldersIn(Folder) 
     If Right(SubFolder, 2) <> "\." And Right(SubFolder, 3) <> "\.." Then 
     For Each SubFile In GetFilesIn(CStr(SubFolder), True) 
      GetFilesIn.Add SubFile 
     Next SubFile 
     End If 
    Next SubFolder 
    End If 
End Function 

Function GetFoldersIn(Folder As String) As Collection 
    Dim F As String 
    Set GetFoldersIn = New Collection 
    F = Dir(Folder & "\*", vbDirectory) 
    Do While F <> "" 
    If GetAttr(Folder & "\" & F) And vbDirectory Then GetFoldersIn.Add JoinPaths(Folder, F) 
    F = Dir 
    Loop 
End Function 

Function JoinPaths(Path1 As String, Path2 As String) As String 
    JoinPaths = Replace(Path1 & "\" & Path2, "\\", "\") 
End Function 

Sub Test() 
    Dim C As Collection, F 

    Debug.Print 
    Debug.Print "Files in C:\" 
    Set C = GetFilesIn("C:\") 
    For Each F In C 
    Debug.Print F 
    Next F 

    Debug.Print 
    Debug.Print "Folders in C:\" 
    Set C = GetFoldersIn("C:\") 
    For Each F In C 
    Debug.Print F 
    Next F 

    Debug.Print 
    Debug.Print "All files in C:\" 
    Set C = GetFilesIn("C:\", True) 
    For Each F In C 
    Debug.Print F 
    Next F 
End Sub