VBA Tipp: Alle Dateien eines Verzeichnisses und seiner Unterverzeichnisse auflisten

Aus DBWiki
Wechseln zu: Navigation, Suche

Anforderung

  • Ich will alle Dateien eines Verzeichnisses und aller seiner Unterverzeichnisse auflisten.
  • Optional kann ich die Suche auch nur auf das aktuelle Verzeichnis (Ordner) beschränken (Parameter OhneUnterordner = True).
  • Wenn der Ordnerpfad ungültig ist, wird ein Fehler ausgelöst.

Lösung

  • Die eingebaute Dir-Funktion erlaubt nur das Durchlaufen des jeweiligen Verzeichnisses, nicht aber von Unterverzeichnissen.
  • Man muss sich daher die zu durchlaufenden Unterverzeichnisse in einer separaten Struktur merken, z.B. in einer Collection.
  • Die folgende Funktion gibt ein String-Array mit den gefundenen Dateien zurück. Wenn keine einzige Datei gefunden wird, wird ein leeres Array zurückgegeben.
Public Function DateienAuflisten(Optional Ordnerpfad As String = "\", _
                                 Optional OhneUnterordner As Boolean) As String()
 
   ' Quelle: http://www.dbwiki.net/
 
 
   Dim idx         As Long
   Dim strDir      As String
   Dim strAktDir   As String
   Dim arrResult() As String
   Dim colDir      As New Collection
 
   If Not Right$(Ordnerpfad, 1) = "\" Then
      Ordnerpfad = Ordnerpfad & "\"
   End If
 
   ' Fehler auslösen, wenn Ordnerpfad ungültig
   Call GetAttr(Ordnerpfad)
 
   colDir.Add Ordnerpfad
 
   Do While colDir.Count > 0
      strAktDir = colDir.Item(1)
      colDir.Remove 1
      strDir = Dir$(strAktDir, vbDirectory)
 
      Do While Len(strDir) > 0
         If strDir <> "." And strDir <> ".." Then
 
            ' Gefundenen Unterordner in Collection einlesen
            If (GetAttr(strAktDir & strDir) And vbDirectory) = vbDirectory Then
               If OhneUnterordner = False Then
                  colDir.Add strAktDir & strDir & "\"
               End If
            Else
               ' Gefundene Datei in Array einlesen
               ReDim Preserve arrResult(idx)
               arrResult(idx) = strAktDir & strDir
               idx = idx + 1
            End If
 
         End If
         strDir = Dir$
      Loop
 
   Loop
 
   DateienAuflisten = arrResult
 
End Function

Aufruf

   Dim strPfad  As String
   Dim strret() As String
   Dim i        As Long
 
   strPfad = CurrentProject.Path & "\MeinOrdner\"
 
   ' Beispiel 1:
   ' Alle Dateien des aktuellen Ordners und aller seiner Unterordner zurückgeben
   strret = DateienAuflisten(strPfad)
 
   ' Beispiel 2:
   ' Alle Dateien nur des aktuellen Ordners zurückgeben
   strret = DateienAuflisten(strPfad, True)
 
   ' Für Beispiel 1 und 2:
   ' Rückgabe-Array mit allen gefundenen Dateien durchlaufen, und alle Dateipfade auflisten
   ' Wenn alle zu durchsuchenden Ordner leer sind, wird ein Fehler ausgelöst.
   On Error Resume Next
   For i = 0 To UBound(strret)
      Debug.Print strret(i)
   Next

Wikilinks

Weblinks