Ottieni l’elenco delle sottodirectory in VBA

  • Voglio ottenere un elenco di tutte le sottodirectory all’interno di una directory.
  • Se funziona, voglio estenderlo a una funzione ricorsiva.

Tuttavia il mio approccio iniziale per ottenere i subdirs fallisce. Mostra semplicemente tutto incluso i file:

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

L’elenco inizia con “..” e diverse cartelle e termina con i file “.txt”.


MODIFICARE:
Dovrei aggiungere che questo deve essere eseguito in Word, non in Excel (molte funzioni non sono disponibili in Word) ed è Office 2010.


MODIFICA 2:

Si può determinare il tipo di risultato usando

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

    Ma questo mi ha dato nuovi problemi, così ora sto usando un codice basato su Scripting.FileSystemObject .

    Aggiornato a luglio 2014: Aggiunta l’opzione PowerShell e taglia il secondo codice per elencare solo le cartelle

    I metodi seguenti che eseguono un processo ricorsivo completo al posto di FileSearch che è stato ritirato in Office 2007. (I due codici successivi utilizzano Excel solo per l’output – questo output può essere rimosso per l’esecuzione in Word)

    1. Shell PowerShell
    2. Utilizzo di FSO con Dir per il filtro del tipo di file. Sourced da questa risposta EE che si trova dietro il paywall EE. Questo è più lungo di quello che hai chiesto (un elenco di cartelle), ma penso che sia utile in quanto ti dà una serie di risultati per lavorare ulteriormente con
    3. Utilizzando Dir . Questo esempio deriva dalla mia risposta che ho fornito su un altro sito

    1. Utilizzando PowerShell per scaricare tutte le cartelle sotto C: \ temp in un file csv

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

    2. Utilizzando FileScriptingObject per scaricare tutte le cartelle sotto C: \ temp in 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 Utilizzo di 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 

    Sarebbe meglio con FileSystemObject. Suppongo.

    Per chiamare ciò di cui hai bisogno, dì: 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 

    Ecco una versione semplice senza utilizzare Scripting.FileSystemObject perché l’ho trovato lento e inaffidabile. In particolare il metodo .Name stava rallentando tutto. Inoltre ho provato questo in Excel ma non penso che qualcosa che ho usato non sarebbe disponibile in Word.

    Prima alcune funzioni:

    Questo unisce due stringhe per creare un percorso file, simile a os.path.join in python. È utile per non aver bisogno di ricordare se hai virato su quel “\” alla fine del tuo percorso.

     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 

    Questo crea una raccolta di root_path della root directory 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 

    Ciò crea una raccolta di elementi secondari nella directory root_path che include le cartelle e quindi rimuove gli elementi che non sono cartelle dalla raccolta. E può facoltativamente rimuovere quelli cattivi . e .. cartelle

     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 

    Infine, la funzione di ricerca ricorsiva basata su un’altra funzione di questo sito che ha utilizzato Scripting.FileSystemObject non ha effettuato alcun test di confronto tra questo e l’originale. Se troverò di nuovo il post, lo collegherò. Nota collec viene passato per riferimento, quindi crea una nuova raccolta e chiama questo sottotitolo per popolarlo. Passare vbType:=vbDirectory per tutte le sottocartelle.

     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 

    Ecco una soluzione VBA, senza utilizzare oggetti esterni.

    A causa delle limitazioni della funzione Dir() è necessario ottenere l’intero contenuto di ciascuna cartella contemporaneamente, non durante la scansione con un algoritmo ricorsivo.

     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 

    MODIFICARE

    Questa versione scava nelle sottocartelle e restituisce i nomi dei percorsi completi invece di restituire solo il nome del file o della cartella.

    NON eseguire il test con l’intera unità 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