循环遍历所有子文件夹-VBA-Queue方法

我使用Cor_blimey的队列方法将驱动器的所有文件夹和子文件夹写入excel工作表，如下所示：

Public Sub NonRecursiveMethod()
    Dim fso, oFolder, oSubfolder, oFile, queue As Collection

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set queue = New Collection
    queue.Add fso.GetFolder("your folder path variable") 'obviously replace

    Do While queue.Count > 0
        Set oFolder = queue(queue.count)
        queue.Remove(queue.count) 'dequeue
        '...insert any folder processing code here...'
       '*...(Here I write the name of the folder to the excel sheet)*.
        For Each oSubfolder In oFolder.SubFolders
            queue.Add oSubfolder 'enqueue
        Next oSubfolder
        For Each oFile In oFolder.Files
       '...insert any file processing code here...
       Next oFile
    Loop

End Sub

我尝试过“后进先出”版本（如上所述）和“先进先出”版本，但它们都没有生成标准的字母顺序列表。上述版本以完全相反的字母顺序列出驱动器，“FIFO”版本以正常的字母顺序生成列表，但它只列出第一级文件夹，然后再次启动并列出所有第二级文件夹，再次按字母顺序，然后是第三级文件夹，再次从“a”开始，等等。因此，子文件夹未列在其父文件夹下

有人知道我能做些什么来获得一个标准的树结构，按文件夹和子文件夹名称的字母顺序排列吗

短暂性脑缺血发作

莱斯

---

更新：由于某些原因，我无法显示此线程上的所有注释或编写新注释。但我想感谢所有人，特别是@Rosenfeld，并说我很想尝试使用

dir

解决方案，但目前工作非常繁忙。过几天我有机会结结巴巴地回来汇报。

我知道您使用的是非递归方法，但无可否认，我想尝试使用递归来解决任务（特别是对于将来可能需要的任何人）

注意：我不确定Scripting.FileSystem文件夹/文件集合是否总是按字母顺序排列的，所以我假设它们在本例中是按字母顺序排列的，但我可能弄错了

从简短的测试中，我没有注意到递归的任何性能问题，但是，根据目录大小，肯定会有一个

最后，main函数中的“CleanOutput”参数用于确定输出中是否显示层次关系

用于测试/输出的方法 主要功能 递归中使用的函数 辅助函数（深度和长度） 实质上发生的是：

• 我们获取一个输入文件夹并确定层次结构的维度 为了那个文件
• 接下来，我们使用这些维度定义一个输出数组
• 使用行计数器和列计数器，我们允许递归函数将其递归结果直接写入层次结构
• 返回这个层次结构，主例程将其直接放到工作表中

你可以采取的下一步行动 我注意到有几件事在这样做

• 除了文件名之外，没有其他信息，文件名取决于 应用，可能会使方法无用
• 包括所有文件 在输出中，不只是重要的文件（不重要的文件） 临时、隐藏等）
• 即使使用

  CleanOutput

  选项，也没有一种简单的方法来绘制父母和孩子之间的关系图

总的来说，这应该足够了，这取决于你的需要。您可以根据需要进行调整。如果您有问题，只需问：）。

我希望工作表的输出看起来像树命令的结果

在我看来，最简单的方法就是使用

树

命令

这里有一种方法，但细节肯定可以改变：

• 在基本文件夹上执行树命令
• 将输出写入某个文本文件（代码中指定的位置和名称）
• 在Excel中将文件作为文本文件打开
• 在垂直条（Unicode字符9474）上拆分为列，Tree命令用于区分级别
• 我使用

  WSH.Run

  方法，因为它可以轻松隐藏

  CMD

  窗口
  • 可以使用

    WSH.Exec

    方法将输出直接传输到VBA变量，但隐藏

    CMD

    窗口要困难得多（这意味着，在另一个应用程序中，我无法）：-）

也可以将文本文件导入同一工作簿，而不是打开新文件。如果你愿意的话，我将把这个练习留给你

Option Explicit
'set referennce to Windows Script Host Object Model
Sub DirTree()
    Dim sBaseFolder As String, sTempFile As String
    Dim WSH As WshShell
    Dim sCMD As String
    Dim lErrCode As Long
    

'Many ways to set starting point
sBaseFolder = Environ("HOMEDRIVE") & "\"
sTempFile = Environ("TEMP") & "\Tree.txt"

'Command line
sCMD = "CMD /c tree """ & sBaseFolder & """ > """ & sTempFile & """"

Set WSH = New WshShell
lErrCode = WSH.Run(sCMD, xlHidden, True)

If Not lErrCode = 0 Then
    MsgBox "Error in execution: Code - " & lErrCode
Else
    'Open the file
    Workbooks.OpenText Filename:=sTempFile, Origin:=xlMSDOS, _
        StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False _
        , Space:=False, Other:=True, OtherChar:=ChrW(&H2502), _
        FieldInfo:=Array(Array(1, 1), Array(2, 1))
End If
    
End Sub

下面是在我的

C:

驱动器上运行时输出开始的屏幕截图

EDIT:由于您现在提到希望链接可以单击，使用

dir

的方法可能会更简单，特别是因为您可以为

dir

命令提供参数，从而返回完整路径

我使用了一个类模块，以便有一个用户定义的对象，该对象将具有必要的信息；以及经过适当过滤后的这些对象的字典

我选择在单元格中仅显示文件夹名称，但屏幕提示将显示完整路径

注意需要设置的引用（在代码中）。还要注意，类模块必须重命名为：cTree

编辑2:对常规模块和类模块进行了编辑，以允许文件的可选列表。请注意，宏现在有一个参数，因此必须从另一个宏或立即窗口调用它，才能包含该参数。（参数也可以从输入框、用户表单等获得，但我现在这样做是因为它更简单

我没有为文件添加超链接，我认为这会让人困惑，因为不同的程序和对话框（文件浏览器除外）会根据扩展名打开

类模块

---

---

正则模

---

选项显式
'设置对Windows脚本主机对象模型的引用
'Microsoft脚本运行时
子GetDirList（bInclFiles为布尔值）
Const sDIRargs As String=“/A-S-L-H/S”
Dim SBASE文件夹作为字符串，sTempFile作为字符串
将WSH暗显为WshShell
作为字符串的Dim sCMD
暗淡的勒尔代码，如长
将FSO设置为文件系统对象，将TS设置为文本流
Dim S作为字符串，sFN作为字符串
尺寸V为变型，W为变型
我想我会坚持多久
变暗lMaxLevel尽可能长
Di
Private Function GetDirectoryFromScriptingFolder(ByVal InputFolder As Scripting.Folder, Optional CleanOutput As Boolean = False) As Variant
    ' Uses recursion to return an organized hierarchy that represents files/folders in the input directory
    Dim CurrentRow As Long
    CurrentRow = 1

    Dim CurrentColumn As Long
    CurrentColumn = 1

    Dim OutputDirectory As Variant
    ReDim OutputDirectory(1 To GetDirectoryLength(InputFolder), 1 To GetDirectoryDepth(InputFolder))

    WriteFolderHierarchy InputFolder, OutputDirectory, CurrentRow, CurrentColumn, CleanOutput

    ' Adjust current column so that files in the parent directory are properly indented
    WriteFileHierarchy InputFolder, OutputDirectory, CurrentRow, CurrentColumn + 1, CleanOutput

    GetDirectoryFromScriptingFolder = OutputDirectory
End Function

Private Sub WriteFolderHierarchy(ByVal InputFolder As Scripting.Folder, ByRef InputHierarchy As Variant, ByRef CurrentRow As Long, ByVal CurrentColumn As Long, ByVal CleanOutput As Boolean)
    If Not IsArray(InputHierarchy) Then Exit Sub

    InputHierarchy(CurrentRow, CurrentColumn) = InputFolder.Name
    CurrentRow = CurrentRow + 1

    Dim StartRow As Long
    Dim SubFolder As Folder
    For Each SubFolder In InputFolder.SubFolders
        ' Use recursion to write the files/folders of each subfolder to the directory
        StartRow = CurrentRow
        WriteFolderHierarchy SubFolder, InputHierarchy, CurrentRow, CurrentColumn + 1, CleanOutput
        WriteFileHierarchy SubFolder, InputHierarchy, CurrentRow, CurrentColumn + 2, CleanOutput

        If CleanOutput Then
            For StartRow = StartRow To CurrentRow
                InputHierarchy(StartRow, CurrentColumn) = "||"
            Next
        End If
    Next
End Sub

Private Sub WriteFileHierarchy(ByVal InputFolder As Scripting.Folder, ByRef InputHierarchy As Variant, ByRef CurrentRow As Long, ByVal CurrentColumn As Long, ByVal CleanOutput As Boolean)
    If Not IsArray(InputHierarchy) Then Exit Sub

    Dim SubFile As File
    For Each SubFile In InputFolder.Files
        ' Write the Files to the Hierarchy
        InputHierarchy(CurrentRow, CurrentColumn) = SubFile.Name
        If CleanOutput Then InputHierarchy(CurrentRow, CurrentColumn - 1) = "--"
        CurrentRow = CurrentRow + 1
    Next
End Sub

Private Function GetDirectoryLength(ByVal InputFolder As Scripting.Folder) As Long
    Dim TotalLength As Long

    ' Include a base of 1 to account for the input folder
    TotalLength = 1 + InputFolder.Files.Count

    Dim SubFolder As Scripting.Folder
    For Each SubFolder In InputFolder.SubFolders
        ' Add 1 to the total to account for the subfolder.
        TotalLength = TotalLength + GetDirectoryLength(SubFolder)
    Next

    GetDirectoryLength = TotalLength
End Function

Private Function GetDirectoryDepth(ByVal InputFolder As Scripting.Folder) As Long
    Dim TotalDepth As Long

    Dim SubFolder As Scripting.Folder
    Dim MaxDepth As Long
    Dim NewDepth As Long
    For Each SubFolder In InputFolder.SubFolders
        NewDepth = GetDirectoryDepth(SubFolder)

        If NewDepth > MaxDepth Then
            MaxDepth = NewDepth
        End If
    Next

    If MaxDepth = 0 Then MaxDepth = 1

    ' Add 1 for the Parent Directory
    GetDirectoryDepth = MaxDepth + 2
End Function

Option Explicit
'set referennce to Windows Script Host Object Model
Sub DirTree()
    Dim sBaseFolder As String, sTempFile As String
    Dim WSH As WshShell
    Dim sCMD As String
    Dim lErrCode As Long
    

'Many ways to set starting point
sBaseFolder = Environ("HOMEDRIVE") & "\"
sTempFile = Environ("TEMP") & "\Tree.txt"

'Command line
sCMD = "CMD /c tree """ & sBaseFolder & """ > """ & sTempFile & """"

Set WSH = New WshShell
lErrCode = WSH.Run(sCMD, xlHidden, True)

If Not lErrCode = 0 Then
    MsgBox "Error in execution: Code - " & lErrCode
Else
    'Open the file
    Workbooks.OpenText Filename:=sTempFile, Origin:=xlMSDOS, _
        StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False _
        , Space:=False, Other:=True, OtherChar:=ChrW(&H2502), _
        FieldInfo:=Array(Array(1, 1), Array(2, 1))
End If
    
End Sub

Option Explicit
'Rename Class Module:  cTree

Private pFullPath As String
Private pFolderName As String
Private pLevel As Long
Private pFile As String
Private pFiles As Dictionary

Public Property Get FullPath() As String
    FullPath = pFullPath
End Property
Public Property Let FullPath(Value As String)
    pFullPath = Value
End Property

Public Property Get FolderName() As String
    FolderName = pFolderName
End Property
Public Property Let FolderName(Value As String)
    pFolderName = Value
End Property

Public Property Get Level() As Long
    Level = pLevel
End Property
Public Property Let Level(Value As Long)
    pLevel = Value
End Property

Public Property Get Files() As Dictionary
    Set Files = pFiles
End Property
Public Function ADDfile(Value As String)
    pFiles.Add Value, Value
End Function
Private Sub Class_Initialize()
    Set pFiles = New Dictionary
    pFiles.CompareMode = TextCompare
End Sub

Option Explicit
'Set reference to Windows Script Host Object Model
'                 Microsoft Scripting Runtime

Sub GetDirList(bInclFiles As Boolean)
    Const sDIRargs As String = " /A-S-L-H /S"
    
    Dim sBaseFolder As String, sTempFile As String
    Dim WSH As WshShell
    Dim sCMD As String
    Dim lErrCode As Long
    
    Dim FSO As FileSystemObject, TS As TextStream
    Dim S As String, sFN As String
    Dim V As Variant, W As Variant
    Dim I As Long
    
    Dim lMaxLevel As Long
    Dim lMinLevel As Long
    
    Dim dctTrees As Dictionary, cT As cTree
    Dim wsRes As Worksheet
    Dim vRes As Variant, rRes As Range
    
'Add worksheet if needed
On Error Resume Next
Set wsRes = Worksheets("TreeLink")
    If Err.Number = 9 Then
        Set wsRes = Worksheets.Add
        wsRes.Name = "TreeLink"
    End If
On Error GoTo 0
Set rRes = wsRes.Cells(1, 1)

    
'Many ways to set starting point
sBaseFolder = Environ("HOMEDRIVE") & "\"
sTempFile = Environ("TEMP") & "\DirList.txt"

'CommandLine
sCMD = "CMD /c dir """ & sBaseFolder & """" & sDIRargs & " > " & sTempFile

Set WSH = New WshShell
lErrCode = WSH.Run(sCMD, xlHidden, True)

If Not lErrCode = 0 Then
    MsgBox "Error in execution: Code - " & lErrCode
    Stop
    
Else
    'Read in the relevant data
    Set dctTrees = New Dictionary
    Set FSO = New FileSystemObject
    Set TS = FSO.OpenTextFile(sTempFile, ForReading, False, TristateUseDefault)
    lMaxLevel = 0
    
    V = Split(TS.ReadAll, vbCrLf)
    
    For I = 0 To UBound(V)
        Do Until V(I) Like " Directory of *"
            If I = UBound(V) Then Exit For
            I = I + 1
        Loop
        Set cT = New cTree
            S = Mid(V(I), 15)
            
            'Can exclude certain directories at this point
            'To exclude all that start with a dot:
            If Not S Like "*\.*" Then
            
            With cT
                .FullPath = S
                .FolderName = Right(S, Len(S) - InStrRev(S, "\"))
                .Level = Len(S) - Len(Replace(S, "\", ""))
                
                lMaxLevel = IIf(lMaxLevel > .Level, lMaxLevel, .Level)
                
                dctTrees.Add Key:=S, Item:=cT
                
                I = I + 1
                
                'Only run for file list
                If bInclFiles = True Then
                Do
                    sFN = V(I)
                    If Not sFN Like "*<DIR>*" _
                            And sFN <> "" Then
                        'add the files
                        dctTrees(S).ADDfile Mid(sFN, 40)
                    End If
                    I = I + 1
                Loop Until V(I) Like "*# File(s)*"
                End If
                
            End With
            
            End If 'End of directory exclusion "if" statement
            
    Next I
    
    lMinLevel = dctTrees(dctTrees.Keys(0)).Level
    
    I = 0
    With rRes.Resize(columnsize:=lMaxLevel + 1).EntireColumn
        .Clear
        .HorizontalAlignment = xlLeft
    End With
    
    Application.ScreenUpdating = False
    
    For Each V In dctTrees.Keys
        Set cT = dctTrees(V)
        With cT
            I = I + 1
            rRes.Worksheet.Hyperlinks.Add _
                Anchor:=rRes(I, .Level - lMinLevel + 1), _
                Address:="File:///" & .FullPath, _
                ScreenTip:=.FullPath, _
                TextToDisplay:=.FolderName
                
            For Each W In .Files.Keys
                I = I + 1
                rRes(I, .Level - lMinLevel + 2) = W
            Next W
        
        End With
    Next V
    
    Application.ScreenUpdating = True
    
End If
End Sub

Sub GetFilesInFolder(SourceFolderName As String)

'--- For Example:Folder Name= "D:\Folder Name\"

Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.folder, SubFolder As Scripting.folder
Dim FileItem As Scripting.File

Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)

'--- This is for displaying, whereever you want can be configured

r = 14
For Each FileItem In SourceFolder.Files
    Cells(r, 2).Formula = r - 13
    Cells(r, 3).Formula = FileItem.Name
    Cells(r, 4).Formula = FileItem.Path
    Cells(r, 5).Formula = FileItem.Size
    Cells(r, 6).Formula = FileItem.Type
    Cells(r, 7).Formula = FileItem.DateLastModified
    Cells(r, 8).Formula = "=HYPERLINK(""" & FileItem.Path & """,""" & "Click Here to Open" & """)"

    r = r + 1   ' next row number
Next FileItem

Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing

Sub GetFilesInFolder(SourceFolderName As String, Subfolders As Boolean)

'--- For Example:Folder Name= "D:\Folder Name\" and Flag as Yes or No

Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.folder, SubFolder As Scripting.folder
Dim FileItem As Scripting.File
'Dim r As Long
    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)

    '--- This is for displaying, whereever you want can be configured

    r = 14
    For Each FileItem In SourceFolder.Files
        Cells(r, 2).Formula = r - 13
        Cells(r, 3).Formula = FileItem.Name
        Cells(r, 4).Formula = FileItem.Path
        Cells(r, 5).Formula = FileItem.Size
        Cells(r, 6).Formula = FileItem.Type
        Cells(r, 7).Formula = FileItem.DateLastModified
        Cells(r, 8).Formula = "=HYPERLINK(""" & FileItem.Path & """,""" & "Click Here to Open" & """)"

        r = r + 1   ' next row number
    Next FileItem

    '--- This is the Function to go each and Every Folder and get the Files. This is a Nested-Function Calling.

    If Subfolders = True Then
        For Each SubFolder In SourceFolder.Subfolders
            ListFilesInFolder SubFolder.Path, True
        Next SubFolder
    End If

    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
End Sub