Dateien auflisten incl. aus Unterordnern

[volti]

Liebe Leserin, lieber Leser,

eine der häufigsten Fragen in Foren ist u.a. die Frage:
- Wie kann ich alle Dateien anhand einer Suchmaske aus einer Verzeichnisstruktur ermitteln?

Die gute, alte Dir-Funktion aus DOS-Zeiten kann nur aus einem Ordner lesen.
Ansonsten gibt es mehrere Wege, FileScripting oder spezielle DOS-Befehle usw..

Heute wollen wir aber mal eine weniger bekannte API-Funktion dafür nutzen.....

Code:


Option Explicit

Private Declare PtrSafe Function EnumDirTreeW Lib "Dbghelp.dll" ( _
                ByVal hProcess As LongPtr, ByVal RootPath As LongPtr, _
                ByVal InputPathName As LongPtr, ByVal OutputPathBuffer As LongPtr, _
                ByVal cb As LongPtr, ByVal data As LongPtr) As Long
Private Declare PtrSafe Function lstrlenW Lib "kernel32.dll" ( _
                ByVal lpString As LongPtr) As Long
Private Declare PtrSafe Function lstrcpyW Lib "kernel32.dll" ( _
                ByVal lpString1 As LongPtr, ByVal lpString2 As LongPtr) As Long
Dim msArrFiles() As String

Private Function DateiListe(ByVal sPfad As String, Optional sDirMaske As String = "*") As Long
' Füllt ein Array mit den Dateipfadnamen
  ReDim Preserve msArrFiles(0)                  ' Dateiarray zurücksetzen
  
  EnumDirTreeW 0, StrPtr(sPfad), StrPtr(sDirMaske), 0, AddressOf CB_EnumDirTree, 0
  DateiListe = UBound(msArrFiles) - 1           ' Anzahl gefundener Dateien zurückgeben

End Function

Private Function CB_EnumDirTree(ByVal lpcwStr As LongPtr, ByVal iNone As Long) As Boolean
  Dim i As Long

  i = UBound(msArrFiles)                        ' Aktuelle Arraygröße ermitteln
  msArrFiles(i) = String(lstrlenW(lpcwStr), 0)  ' Variable mit ausreichend Platz schaffen
  lstrcpyW StrPtr(msArrFiles(i)), lpcwStr       ' String umkopieren
  ReDim Preserve msArrFiles(i + 1)              ' Array neu dimensionieren
End Function


' ##### Aufruftests #####
Private Sub Demo1()
  Dim i As Long
  
  i = DateiListe("C:\Users\voltm\Desktop\MyTools", "*")
  If i < 0 Then
    MsgBox "Habe keine Dateien gefunden!", vbCritical
  Else
    For i = 0 To i
        Debug.Print msArrFiles(i)
    Next i
    MsgBox "Habe " & i & " Dateien gefunden!", vbInformation
  End If
End Sub

Private Sub Demo2()
  Dim i As Long
  
  i = DateiListe("C:\Users\voltm\Desktop\MyTools", "Excel*")
  If i >= 0 Then
    ActiveSheet.Cells(1, 1).Resize(i + 1, 1) = WorksheetFunction.Transpose(msArrFiles)
  End If
End Sub

_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz