获取 VBA 中的子目录列表

Posted

技术标签:

【中文标题】获取 VBA 中的子目录列表【英文标题】：Get list of sub-directories in VBA 【发布时间】：2012-04-07 08:02:34 【问题描述】： 我想获得一个目录中所有子目录的列表。 如果可行，我想将其扩展为递归函数。

但是，我最初获取子目录的方法失败了。它只显示包括文件在内的所有内容：

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的代码。

【问题讨论】：

我只想坚持使用 vba。不是脚本主机或其他 dll 基础技巧。它适用于 Word of Office 2010。最好使用Dir，因为我想知道我的示例为何失败。 【参考方案1】：

使用 FileSystemObject 会更好。我想。

要调用它，你只需要说： 列表文件夹“c:\data”

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

【讨论】：

我认为问题的意图是在找到第一级子文件夹的初始问题后找到所有子目录，即'如果可行，我想将其扩展为递归函数" @brettdj 我不是这样读的。我把它读作“如果代码有效”而不是“如果找到目录”。无论哪种情况，FileSystemObject 找到目录这一事实都会有所帮助，毕竟递归行可以很容易地被注释掉，然后将列出所有第一级目录。 不可能：Dim FS As New FileSystemObject给我“类型未定义” @MatthiasPospiech 也许您没有看到 Dim 行正上方的注释，说明需要哪个参考，如果您不希望添加参考，建议您使用替代方法？ @SandPiper 这就是为什么他说" If you prefer, just Dim everything as Object and use CreateObject("Scripting.FileSystemObject") "【参考方案2】：

2014 年 7 月更新：添加了 PowerShell 选项并减少第二个代码以仅列出文件夹

下面的方法运行完整的递归过程来代替 Office 2007 中已弃用的 FileSearch。（后面的两个代码仅使用 Excel 进行输出 - 可以删除此输出以在 Word 中运行）

    壳牌PowerShell 使用FSO 和Dir 过滤文件类型。来自位于 EE 付费墙后面的 EE answer。这比您要求的要长（文件夹列表），但我认为它很有用，因为它为您提供了一系列结果以进一步使用 使用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

【讨论】：

很好的例子 :) 该死！它不允许我投票。好像已经在 3 月 26 日投票了：D 我会使用集合而不是在循环中重新调整数组。 excelmacromastery.com/excel-vba-collections【参考方案3】：

这是一个没有使用Scripting.FileSystemObject 的简单版本，因为我发现它速度慢且不可靠。特别是 .Name 方法，正在减慢一切。我也在 E​​xcel 中对此进行了测试，但我认为我使用的任何东西都不会在 Word 中可用。

首先是一些函数：

这将连接两个字符串以创建文件路径，类似于 python 中的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

【讨论】：

确实.Name 在文件夹对象上很慢【参考方案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

【讨论】：

它不会深入到子文件夹中 @Qbik 我添加了一个挖掘子文件夹的版本。

以上是关于获取 VBA 中的子目录列表的主要内容，如果未能解决你的问题，请参考以下文章

VBA - 如何在 Excel 2010 的目录中获取最后修改的文件或文件夹

VBA获取某文件夹下所有文件和子文件目录的文件

Excel VBA 代码在 Open Office 中不起作用（列表中的代码复制文件）

从 VBA 获取当前目录

获取滚动列表框 VBA 中的顶部项目

Vba代码从列表中获取特定项目的数据排名