Obter lista de subdiretórios no VBA

  • Eu quero obter uma lista de todos os subdiretórios dentro de um diretório.
  • Se isso funcionar, quero expandi-lo para uma function recursiva.

No entanto, minha abordagem inicial para obter os subdiretórios falha. Ele simplesmente mostra tudo, incluindo arquivos:

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

A lista começa com ‘..’ e várias pastas e termina com arquivos ‘.txt’.


EDITAR:
Devo acrescentar que isso deve ser executado no Word, não no Excel (muitas funções não estão disponíveis no Word) e é o Office 2010.


EDIT 2:

Pode-se determinar o tipo do resultado usando

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

Mas isso me deu novos problemas, de modo que agora estou usando um código baseado em Scripting.FileSystemObject .

Atualizado em julho de 2014: adicionada a opção PowerShell e reduz o segundo código para listar apenas as pastas

Os methods abaixo executam um processo recursivo completo no lugar do FileSearch que foi preterido no Office 2007. (Os dois códigos posteriores usam o Excel somente para saída – essa saída pode ser removida para execução no Word)

  1. Shell PowerShell
  2. Usando o FSO com Dir para filtrar o tipo de arquivo. Obtido a partir desta resposta EE que fica atrás do paywall da EE. Isso é mais do que o que você pediu (uma lista de pastas), mas eu acho que é útil, pois dá-lhe uma variedade de resultados para trabalhar mais com
  3. Usando Dir . Este exemplo vem da minha resposta que forneci em outro site

1. Usando o PowerShell para despejar todas as pastas abaixo de C: \ temp em um arquivo csv

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

2. Usando o FileScriptingObject para despejar todas as pastas abaixo de C: \ temp no 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 Usando 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 

Você ficaria melhor com o FileSystemObject. Eu acho.

Para chamar isso, você só precisa dizer: listfolders “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 

Aqui está uma versão simples sem usar Scripting.FileSystemObject porque achei lento e não confiável. Em particular, o método .Name estava atrasando tudo. Também testei isso no Excel, mas não acho que algo que usei não estaria disponível no Word.

Primeiro algumas funções:

Isso une duas strings para criar um caminho de arquivo, semelhante ao os.path.join em python. É útil para não precisar lembrar se você colocou esse “\” no final do caminho.

 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 

Isso cria uma coleção de subitens do diretório raiz 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 

Isso cria uma coleção de subitens no diretório root_path que inclui pastas e remove itens que não são pastas da coleção. E, opcionalmente, pode remover esses desagradáveis . e .. pastas

 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 

Finalmente é a function de pesquisa recursiva baseada em outra function deste site que usou Scripting.FileSystemObject Eu não fiz nenhum teste de comparação entre ele e o original. Se eu encontrar esse post novamente eu vou ligar. Observação collec é passado por referência para criar uma nova coleção e chamar esse sub para preenchê-lo. Pass vbType:=vbDirectory para todas as subpastas.

 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 

Aqui está uma solução VBA, sem usar objects externos.

Devido às limitações da function Dir() , você precisa obter todo o conteúdo de cada pasta de uma só vez, não durante o rastreamento com um algoritmo recursivo.

 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 

EDITAR

Essa versão é inserida em subpastas e retorna nomes de caminho completos, em vez de retornar apenas o nome do arquivo ou da pasta.

NÃO execute o teste com toda a unidade 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