VBA Tipp: Verzeichnisbaum durchsuchen

Aus DBWiki
Wechseln zu: Navigation, Suche

Anforderung

  • Ich will einen Verzeichnisbaum (Ordner mit Unterordnern) nach Dateien eines bestimmten Dateityps durchsuchen.
  • Optional kann ich die Suche auch nur auf den aktuellen Ordner beschränken (Parameter OhneUnterordner = True).
  • Wenn der optionale Parameter Dateityp weggelassen wird, werden alle Dateien des aktuellen Ordners und wahlweise aller seiner Unterordner zurückgegeben.
  • 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.
Public Function DateienSuchen(Optional Ordnerpfad As String = "\", _
                              Optional Dateityp As String, _
                              Optional OhneUnterordner As Boolean) As String()
 
   'Quelle: www.dbwiki.net oder www.dbwiki.de
 
   Dim idx         As Long
   Dim lngTyp      As Long
   Dim strDir      As String
   Dim strAktDir   As String
   Dim colDir      As New Collection
   Dim arrResult() As String
 
   lngTyp = Len(Dateityp)
 
   If 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) <> 0 Then
               If OhneUnterordner = False Then
                  colDir.Add strAktDir & strDir & "\"
               End If
            Else
               'Gefundene Datei in Array einlesen
               If Right(strDir, lngTyp) = Dateityp Then
                  ReDim Preserve arrResult(idx)
                  arrResult(idx) = strAktDir & strDir
                  idx = idx + 1
               End If
            End If
         End If
         strDir = Dir$
      Loop
 
   Loop
 
   Set colDir = Nothing
 
   DateienSuchen = arrResult
 
End Function

Aufruf

   Dim strPfad  As String
   Dim strret() As String
   Dim i        As Long
 
   strPfad = CurrentProject.Path & "\MeinOrdner"
 
   'Beispiel 1:
   'Hinweis: Wenn keine Datei gefunden wird, tritt ein Fehler auf
   'Erste gefundene Datei anzeigen
   Debug.Print DateienSuchen(strPfad, ".pdf")(0)
   'Zweite gefundene Datei anzeigen
   Debug.Print DateienSuchen(strPfad, ".pdf")(1)
 
 
   'Beispiel 2a:
   'Alle pdf-Dateien des aktuellen Ordners und aller Unterordner zurückgeben
   strret() = DateienSuchen(strPfad, ".pdf")
 
   'Beispiel 2b:
   'Alle pdf-Dateien nur des aktuellen Ordners zurückgeben
   strret() = DateienSuchen(strPfad, ".pdf", True)
 
   'Beispiel 2c:
   'Alle Dateien des aktuellen Ordners und aller seiner Unterordner zurückgeben
   strret = DateienSuchen(strPfad)
 
   'Beispiel 2d:
   'Alle Dateien nur des aktuellen Ordners zurückgeben
   strret = DateienSuchen(strPfad, , True)
 
   'Für Beispiel 2a - 2d:
   '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