para - obtener una lista de subdirectores en vba

vba word object model

Question

• Quiero obtener una lista de todos los subdires en una carpeta.
• 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 agregar 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 .

Answer 1

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

Answer 2

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

Answer 3

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 insertaste esa "/" al final de tu camino.

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

Answer 4

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