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

查看：29
本文介绍了获取 VBA 中的子目录列表的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！

问题描述

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

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

sDir = Dir(sPath, vbDirectory)直到 LenB(sDir) = 0Debug.Print sDirsDir = 目录环形

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

<小时>


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

<小时>

编辑 2:

可以使用

来确定结果的类型

iAtt = GetAttr(sPath & sDir)如果 CBool​​(iAtt 和 vbDirectory) 那么...万一

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

解决方案

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

下面的方法运行完整的递归过程，而不是在 Office 2007 中弃用的 FileSearch.(后两个代码仅使用 Excel 进行输出 - 此输出可以删除在 Word 中运行)

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

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

Sub Comesfast()X2 = Shell("powershell.exe Get-ChildItem c:	emp -Recurse | ?{ $_.PSIsContainer } | export-csv C:	empfilename.csv", 1)结束子

2.使用 FileScriptingObject 将 C: emp 下的所有文件夹转储到 Excel 中

Public Arr() As String公共柜台只要子 LoopThroughFilePaths()调暗我的ArrDim strPath 作为字符串strPath = "c:	emp"myArr = GetSubFolders(strPath)[A1].Resize(UBound(myArr, 1), 1) = Application.Transpose(myArr)结束子函数 GetSubFolders(RootPath As String)将 fso 调暗为对象Dim fld 作为对象Dim sf 作为对象调暗我的ArrSet fso = CreateObject("Scripting.FileSystemObject")设置 fld = fso.GetFolder(RootPath)对于 fld.SUBFOLDERS 中的每个 sfReDim Preserve Arr(柜台)Arr(Counter) = sf.Path计数器 = 计数器 + 1myArr = GetSubFolders(sf.Path)下一个GetSubFolders = 到达设置 sf = 无设置 fld = 无设置 fso = 无结束函数

3 使用Dir

 选项显式公共 StrArray()公共 lngCnt 只要公共 b_OS_XP 作为布尔值公共枚举 MP3Tags' 请参阅 http://www.kixtart.org/forums/ubbthreads.php?ubb=showflat&Number=160880&page=1 了解操作系统特定的属性列表XP_艺术家 = 16XP_AlbumTitle = 17XP_SongTitle = 10XP_TrackNumber = 19XP_RecordingYear = 18XP_流派 = 20XP_Duration = 21XP_BitRate = 22Vista_W7_Artist = 13Vista_W7_AlbumTitle = 14Vista_W7_SongTitle = 21Vista_W7_TrackNumber = 26Vista_W7_RecordingYear = 15Vista_W7_流派 = 16Vista_W7_Duration = 17Vista_W7_BitRate = 28结束枚举公共子主()昏暗的对象昏暗的 objWMI 服务昏暗的col操作系统昏暗的对象操作系统昏暗的对象FSO昏暗的对象文件夹Dim Wb 作为工作簿Dim ws As 工作表Dim strobjFolderPath As StringDim strOS 作为字符串Dim strMyDoc As StringDim strComputer As String'为用户设置应用程序有申请.ScreenUpdating = 假.DisplayAlerts = 假结束于'重置公共变量lngCnt = 0ReDim StrArray(1 到 10, 1 到 1000)' 使用 wscript 自动定位我的文档目录Set objws = CreateObject("wscript.shell")strMyDoc = objws.SpecialFolders("MyDocuments")strComputer = "."Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\" & strComputer & "
ootcimv2")Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")对于 colOperatingSystems 中的每个 objOperatingSystemstrOS = objOperatingSystem.Caption下一个Set objFSO = CreateObject("Scripting.FileSystemObject")如果 InStr(strOS, "XP") 那么b_OS_XP = 真别的b_OS_XP = 假万一' 格式化输出表设置 Wb = Workbooks.Add(1)设置 ws = Wb.Worksheets(1)ws.[a1] = 现在()ws.[a2] = strOSws.[a3] = strMyDocws.[a1:a3].Horizo​​ntalAlignment = xlLeftws.[A4:J4].Value = Array("Folder", "File", "Artist", "Album Title", "Song Title", "Track Number", "Recording Year", "Genre", "Duration", "比特率")ws.Range([a1], [j4]).Font.Bold = Truews.Rows(5).SelectActiveWindow.FreezePanes = TrueSet objFSO = CreateObject("Scripting.FileSystemObject")设置 objFolder = objFSO.GetFolder(strMyDoc)' 开始收集文件的代码ShowSubFolders objFolder, TrueShowSubFolders objFolder, False如果 lngCnt >0 那么' 完成输出使用 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结束于ws.[a1].Activate别的MsgBox "没有找到文件！", vbCriticalWb.Close 错误万一' 整理设置 objFSO = 无设置 objws = 无有申请.ScreenUpdating = 真.DisplayAlerts = 真.StatusBar = vbNullString结束于结束子Sub ShowSubFolders(ByVal objFolder, bRootFolder As Boolean)昏暗的 objShell昏暗的 objShellFolder昏暗的 objShellFolderItem昏暗的文件夹Dim obj 子文件夹'strName 必须是一个变体，因为 ParseName 不适用于字符串参数模糊的字符串名称Set objShell = CreateObject("Shell.Application")设置 colFolders = objFolder.SubFoldersApplication.StatusBar = "正在处理" &objFolder.Path如果 bRootFolder 那么设置 objSubfolder = objFolder转到 OneTimeRoot万一对于 colFolders 中的每个 objSubfolder'检查是否要处理根目录文件一次性根:strFname = Dir(objSubfolder.Path & "*.mp3")设置 objShellFolder = objShell.Namespace(objSubfolder.Path)做而 Len(strFname) >0lngCnt = lngCnt + 1如果 lngCnt Mod 1000 = 0 那么 ReDim Preserve StrArray(1 To 10, 1 To (lngCnt + 1000))设置 objShellFolderItem = objShellFolder.ParseName(strFname)StrArray(1, lngCnt) = objSubfolderStrArray(2, lngCnt) = strFname如果 b_OS_XP 那么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)别的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)万一strFname = 目录环形如果 bRootFolder 那么bRootFolder = False退出子万一ShowSubFolders objSubfolder, False下一个结束子

  • I want to get a list of all sub-directories within a directory.
  • If that works I want to expand it to a recursive function.

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

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

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

EDIT 2:

One can determine the type of the result using

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

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

解决方案

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

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. 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. Using PowerShell to dump all folders below C: emp into a csv file

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

2. Using FileScriptingObject to dump all folders below C: emp into Excel

Public Arr() As String
Public Counter As Long

Sub LoopThroughFilePaths()
Dim myArr
Dim strPath As String
strPath = "c:	emp"
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 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 & "
ootcimv2")
    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屋！

查看全文
相关文章
其他开发最新文章
热门教程
热门工具
登录 关闭
扫码关注1秒登录
发送“验证码”获取 | 15天全站免登陆