Блог

Главная - Вопросы по программированию - Получить список подкаталогов в VBA

Получить список подкаталогов в VBA

#excel #vba

Вопрос:

  • Я хочу получить список всех подкаталогов в каталоге.
  • Если это сработает, я хочу расширить его до рекурсивной функции.

Однако мой первоначальный подход к получению поддиров терпит неудачу. Он просто показывает все, включая файлы:

 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 amp; sDir)
If CBool(iAtt And vbDirectory) Then
   ...
End If

Но это создало мне новые проблемы, так что теперь я использую код, основанный на Scripting.FileSystemObject .

Комментарии:

1. Я хотел бы придерживаться только vba. Не скриптовый хост или другие трюки с базами dll. И он должен работать с Word of Office 2010. В лучшем случае с Dir , так как я хотел бы знать, почему мой пример терпит неудачу.

Ответ №1:

Обновлено в июле 2014 года: Добавлена PowerShell опция и сокращен второй код только для списка папок

Приведенные ниже методы, которые запускают полный рекурсивный процесс вместо FileSearch устаревшего в Office 2007. (Два последних кода используют Excel только для вывода — этот вывод можно удалить для запуска в Word)

  1. Ракушка PowerShell
  2. Использование FSO с Dir для фильтрации типа файла. Получено из этого ответа EE, который находится за платежной системой EE. Это больше, чем вы просили (список папок), но я думаю, что это полезно, так как это дает вам множество результатов для дальнейшей работы
  3. С помощью Dir . Этот пример взят из моего ответа, который я предоставил на другом сайте

1. Использование PowerShell для сброса всех папок ниже C:temp в файл csv

 Sub Comesfast()
X2 = Shell("powershell.exe Get-ChildItem c:temp -Recurse | ?{ $_.PSIsContainer } | export-csv C:tempfilename.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=showflatamp;Number=160880amp;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:" amp; "{impersonationLevel=impersonate}!\" amp; strComputer amp; "rootcimv2")
    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 " amp; 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 amp; "*.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

Комментарии:

1. Хороший пример 🙂 Черт! это не позволяет мне голосовать за это. Похоже, что вы уже проголосовали за это 26 марта 😀

2. Я бы использовал коллекцию вместо повторного отображения массива в цикле. excelmacromastery.com/excel-vba-collections

Ответ №2:

Вам было бы лучше использовать объект 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

Комментарии:

1. Я думаю, что цель вопроса состояла в том, чтобы найти все подкаталоги, как только будет решена начальная проблема поиска вложенных папок первого уровня, т. Е.»Если это сработает, я хочу расширить его до рекурсивной функции».

2. @brettdj Это было не так, как я это прочитал. Я прочитал это как «если код работает», а не «если каталог найден». В любом случае тот факт, что объект FileSystemObject находит каталоги, поможет, в конце концов, строку рекурсии можно легко закомментировать, после чего будут перечислены все каталоги первого уровня.

3. Невозможно: Dim FS As New FileSystemObject выдает мне «Тип не определен»

4. @MatthiasPospiech Возможно, вы не видели комментарий непосредственно над тусклой строкой, в котором говорится, какая ссылка требуется, и предлагается альтернатива, если вы не хотите добавлять ссылку?

5. @SandPiper, вот почему он сказал " If you prefer, just Dim everything as Object and use CreateObject("Scripting.FileSystemObject") "

Ответ №3:

Вот решение VBA, без использования внешних объектов.

Из-за ограничений Dir() функции вам нужно получить все содержимое каждой папки сразу, а не во время обхода с помощью рекурсивного алгоритма.

 Function GetFilesIn(Folder As String) As Collection
  Dim F As String
  Set GetFilesIn = New Collection
  F = Dir(Folder amp; "*")
  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 amp; "*", vbDirectory)
  Do While F <> ""
    If GetAttr(Folder amp; "" amp; 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 amp; "*")
  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 amp; "*", vbDirectory)
  Do While F <> ""
    If GetAttr(Folder amp; "" amp; 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 amp; "" amp; 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

Комментарии:

1. он не копается во вложенных папках

2. @Qbik Я добавил версию, которая копается во вложенных папках.

Ответ №4:

Вот простая версия без использования Scripting.FileSystemObject , потому что я нашел ее медленной и ненадежной. В частности .Name , метод замедлял все. Также я проверил это в Excel, но я не думаю, что что-то, что я использовал, было бы недоступно в Word.

Сначала некоторые функции:

Это объединяет две строки для создания пути к файлу, аналогично os.path.join тому, как в python. Это полезно для того, чтобы не нужно было запоминать, нажали ли вы на это «» в конце своего пути.

 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 amp; file_path
    Else
        pjoin = root_path amp; sep amp; 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 amp; "."
        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

Комментарии:

1. Действительно. Имя очень медленно отображается на объекте папки

Метки: