'http://www.vbarchiv.net/tipps/tipp_126-ermitteln-aller-dateien-eines-ordners-unterordners.html
' zunächst die benötigten API-Deklarationen
Public Declare PtrSafe Function FindFirstFile Lib "kernel32" _
  Alias "FindFirstFileA" ( _
  ByVal lpFileName As String, _
  lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare PtrSafe Function FindNextFile Lib "kernel32" _
  Alias "FindNextFileA" ( _
  ByVal hFindFile As Long, _
  lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare PtrSafe Function FindClose Lib "kernel32" ( _
  ByVal hFindFile As Long) As Long
Public Declare PtrSafe Function GetShortPathName Lib "kernel32" _
  Alias "GetShortPathNameA" ( _
  ByVal lpszLongPath As String, _
  ByVal lpszShortPath As String, _
  ByVal cchBuffer As Long) As Long
 
Public Const MAX_PATH = 260
Public Const INVALID_HANDLE_VALUE = -1
 
Public Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type
 
'Private Type WIN32_FIND_DATA
Public Type WIN32_FIND_DATA
  dwFileAttributes As Long ' Dateiattribute
  ftCreationTime As FILETIME ' Erstellungsdatum
  ftLastAccessTime As FILETIME ' Letzter Zugriff
  ftLastWriteTime As FILETIME ' Letzte Speicherung
  nFileSizeHigh As Long ' Größe (Hi)
  nFileSizeLow As Long ' Größe (Lo)
  dwReserved0 As Long ' bedeutungslos
  dwReserved1 As Long ' bedeutungslos
  cFileName As String * MAX_PATH ' Dateiname
  cAlternate As String * 14 ' 8.3-Dateiname
End Type
 
Public Type Datei
  Pfadname As String
  DosDateiname As String
  Dateiname As String
  ErstelltAM As FILETIME
  LetzterZugriff As FILETIME
  LetzeÄnderung As FILETIME
  DateiGröße As Long
  Atribute As Long
End Type

-------------------------------------------------------------

'http://www.vbarchiv.net/tipps/tipp_126-ermitteln-aller-dateien-eines-ordners-unterordners.html
'Suchroutine: Wildcards sind erlaubt (*.*, ?, ect.)
Public Function FindFile(ByVal StartPath As String, _
  ByVal SearchSubfolder As Boolean, _
  ByVal File As String, _
  ByRef FileFound() As Datei)
 
  Dim hFile As Long
  Dim FileData As WIN32_FIND_DATA
  Dim Directories() As String
  Dim OnlyDirectories As Boolean
  Dim TmpFile As String
  Dim I As Integer
 
  DoEvents
 
 'Evtl. Backslash entfernen
 If Right$(StartPath, 1) = "\" Then StartPath = Left$(StartPath, Len(StartPath) - 1)
 
SearchOnlySubfolders:
 
  'Sucht nach einer Datei, und packt das Ergebnis in FileData
  hFile = FindFirstFile(StartPath & "\" & File & vbNullChar, FileData)
 
  'Wenn sie gefunden wurde, dann...
  If hFile <> INVALID_HANDLE_VALUE Then
 
    Do
      'Ist es ein Verzeichniss oder eine Datei ?
      With FileData
        If (.dwFileAttributes And vbDirectory) = 0 Then
          'Datei
 
          'Nur wenn nicht nur Verzeichinsse gesucht werden
          If Not OnlyDirectories Then
            'Array vergrößern und Daten ins Array schreiben
            On Error GoTo Err_DimFile
            ReDim Preserve FileFound(UBound(FileFound) + 1)
            On Error GoTo 0
 
            DoEvents
            UmPacken FileFound(UBound(FileFound)), FileData, StartPath & "\" & File
 
          End If
 
        ElseIf SearchSubfolder = True Then
          'Verzeichnis
 
          'Verzeichnis nur im Array Speichern wenn es über dem jetzigen liegt d.h. ".." "." sind nicht gültig
          If Left$(.cFileName, InStr(.cFileName, vbNullChar) - 1) <> "." And Left$(.cFileName, InStr(.cFileName, vbNullChar) - 1) <> ".." Then
 
            On Error GoTo Err_DimDir
            ReDim Preserve Directories(UBound(Directories) + 1)
            On Error GoTo 0
 
            'Verzeichnis dem Array hinzufügen
            Directories(UBound(Directories)) = Left$(.cFileName, InStr(.cFileName, vbNullChar) - 1)
          End If
 
        End If
      End With
      DoEvents
    Loop Until FindNextFile(hFile, FileData) = 0
  End If
  FindClose hFile
 
  'Unterordner durchsuchen
  On Error GoTo Err_DimDir
  If SearchSubfolder = False Then Exit Function
  On Error GoTo 0
 
  'Wenn nach anderen Dateien als *.* gesucht wird, werden keine Ordner gefunden
  'Deshalb noch einmal gezielt nach Ordnern suchen
  If Not OnlyDirectories And SearchSubfolder = True And File <> "*.*" Then
 
    OnlyDirectories = True
    TmpFile = File
    File = "*.*"
    GoTo SearchOnlySubfolders
  ElseIf TmpFile <> "" Then
    File = TmpFile
  End If
 
  On Error GoTo Err_Exit
  For I = 0 To UBound(Directories)
    DoEvents
 
    'Hier ruft die Funktion sich selbst auf - für jeden Unterordner
    FindFile StartPath & "\" & Directories(I), SearchSubfolder, File, FileFound
  Next I
  Exit Function
 
Err_DimFile:
   ReDim FileFound(0)
   Resume Next
 
Err_DimDir:
   ReDim Directories(0)
   Resume Next
 
Err_Exit:
End Function

-----------------------------------------------------------------------

'http://www.vbarchiv.net/tipps/tipp_126-ermitteln-aller-dateien-eines-ordners-unterordners.html
'Packt die Infos um und schneidet Nullchar-Zeichen ab
Private Function UmPacken(ByRef D As Datei, FD As WIN32_FIND_DATA, ByVal Path As String)
 
  With FD
    D.Atribute = .dwFileAttributes
    D.DateiGröße = .nFileSizeLow
    D.Dateiname = Left$(.cFileName, InStr(.cFileName, vbNullChar) - 1)
    D.DosDateiname = Left$(.cAlternate, InStr(.cAlternate, vbNullChar) - 1)
    If D.DosDateiname = "" Then D.DosDateiname = D.Dateiname
    D.ErstelltAM = .ftCreationTime
    D.LetzeÄnderung = .ftLastWriteTime
    D.LetzterZugriff = .ftLastAccessTime
    D.Pfadname = Left$(Path, InStrRev(Path, "\"))
  End With
End Function