获取VBA中的子目录列表 [英] Get list of sub-directories in VBA

问题描述

• 我想获取目录中所有子目录的列表.
• 如果可行，我想将其扩展为递归函数.

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

However my initial approach to get the subdirs fails. It simply shows everything including files:

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

该列表以".."开头和几个文件夹，以".txt"文件结尾.

The list starts with '..' and several folders and ends with '.txt' files.

我应该补充一点，它必须在Word中运行，而不是在Excel中运行(许多功能在Word中不可用)，并且它是Office 2010.

I should add that this must run in Word, not Excel (many functions are not available in Word) and it is Office 2010.

一个人可以使用确定结果的类型

One can determine the type of the result using

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

但这给我带来了新的问题，因此我现在使用的是基于Scripting.FileSystemObject的代码.

But that gave me new problems, so that I am now using a code based on Scripting.FileSystemObject.

推荐答案

2014年7月更新:添加了PowerShell选项，并将第二个代码削减为仅列出文件夹

Updated July 2014: Added PowerShell option and cut back the second code to list folders only

下面的方法代替Office 2007中已弃用的FileSearch运行完整的递归过程.(后两个代码仅将Excel用于输出-可以删除此输出以在Word中运行)

The methods below that run a full recursive process in place of FileSearch which was deprecated in Office 2007. (The later two codes use Excel for output only - this output can be removed for running in Word)

1. 壳牌PowerShell
2. 使用FSO和Dir来过滤文件类型.源自EE付费墙后面的 EE答案.这比您要的要长(文件夹列表)，但我认为它很有用，因为它可以为您提供一系列结果，以供进一步使用
3. 使用Dir.这个例子来自我在另一个网站上提供的答案

1. Shell PowerShell
2. Using FSO with Dir for filtering file type. Sourced from this EE answer which sits behind the EE paywall. This is longer than what you asked for (a list of folders) but i think it is useful as it gives you an array of results to work further with
3. Using Dir. This example comes from my answer I supplied on another site

1.使用PowerShell将C:\ temp下的所有文件夹转储到csv文件中

1. Using PowerShell to dump all folders below C:\temp into a csv file

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

2. Using FileScriptingObject to dump all folders below C:\temp into 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

3 Using 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

这篇关于获取VBA中的子目录列表的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！