Obtener lista de subdirectorios en VBA

  • Quiero obtener una lista de todos los subdirectorios dentro de un directorio.
  • Si eso funciona, quiero expandirlo a una función recursiva.

Sin embargo, mi enfoque inicial para obtener los subdires falla. Simplemente muestra todo, incluidos los archivos:

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

La lista comienza con ‘..’ y varias carpetas y termina con los archivos ‘.txt’.


EDITAR:
Debo añadir que esto debe ejecutarse en Word, no en Excel (muchas funciones no están disponibles en Word) y es Office 2010.


EDICION 2:

Uno puede determinar el tipo de resultado usando

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

Pero eso me dio nuevos problemas, por lo que ahora estoy usando un código basado en Scripting.FileSystemObject .

    Actualizado en julio de 2014: se agregó la opción de PowerShell y se recortó el segundo código para mostrar solo las carpetas

    Los métodos a continuación que ejecutan un proceso recursivo completo en lugar de FileSearch que estaba en desuso en Office 2007. (Los dos códigos posteriores usan Excel solo como salida; esta salida se puede quitar para ejecutar en Word)

    1. Shell PowerShell
    2. Usar FSO con Dir para filtrar el tipo de archivo. Procedente de esta respuesta de EE que se encuentra detrás del muro de pagos EE. Esto es más largo de lo que pediste (una lista de carpetas) pero creo que es útil, ya que te da una serie de resultados para trabajar más con
    3. Usando Dir . Este ejemplo proviene de mi respuesta que proporcioné en otro sitio

    1. Usando PowerShell para volcar todas las carpetas debajo de C: \ temp en un archivo csv

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

    2. Usando FileScriptingObject para volcar todas las carpetas debajo de C: \ temp en 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 

    Estarías mejor con FileSystemObject. Creo que.

    Para llamar a esto, solo necesita, digamos: 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 

    Aquí hay una versión simple sin usar Scripting.FileSystemObject porque la encontré lenta y poco confiable. En particular, el método .Name estaba ralentizando todo. También probé esto en Excel, pero no creo que nada de lo que utilicé no esté disponible en Word.

    Primero algunas funciones:

    Esto une dos cadenas para crear una ruta de archivo, similar a os.path.join en python. Es útil para no tener que recordar si insertó esa “\” al final de su ruta.

     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 

    Esto crea una colección de elementos secundarios del directorio raíz 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 

    Esto crea una colección de elementos secundarios en el directorio root_path que incluye carpetas y luego elimina elementos que no son carpetas de la colección. Y opcionalmente puede eliminar esos desagradable . y .. carpetas

     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, la función de búsqueda recursiva basada en la función de otra persona de este sitio que usó Scripting.FileSystemObject no he hecho ninguna prueba de comparación entre ella y el original. Si encuentro esa publicación nuevamente, la vincularé. Note que la collec se pasa por referencia, de modo que cree una nueva colección y llame a este sub para llenarla. Pase vbType:=vbDirectory para todas las subcarpetas.

     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 

    Aquí hay una solución VBA, sin usar objetos externos.

    Debido a las limitaciones de la función Dir() , necesita obtener todo el contenido de cada carpeta a la vez, no mientras rastrea con un 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

    Esta versión profundiza en las subcarpetas y devuelve los nombres completos de las rutas en lugar de devolver solo el nombre del archivo o la carpeta.

    NO ejecutes la prueba con toda la unidad 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