Dateiliste

Mit Hilfe der API-Funktionen FindFirstFile und FindNextFile lässt sich relativ leicht eine Dateiliste erstellen, die folgende Infos liefert:
8+3 Name, Erstellungszeitpunkt, Änderungszeitpunkt, Letzter Zugriff und die Größe.
Und das sehr schnell.

Beispieldatei (Verzeichnisbaum.zip 25 KB)

##############################################
'# Ein Blatt mit dem Namen Datenbaum, welches
'# die Dateiinfos ab Zeile 6 aufnimmt.
'# Der Startpfad in Zelle E1
'##############################################

Option Explicit
Private Sub cmbDateiliste_Click()
Dim Pfad As String, a As New clsVerzeichnisbaum
Dim Zähler As Long, Zähler1 As Long, Zielbereich(1 To 8)
Dim Überschrift, d As Variant
On Error Resume Next
With Sheets("Datenbaum")
   Pfad = .Range("E1")
   .Range(.Cells(6, 1), .Cells(65536, 256)).Delete
   d = .UsedRange.Cells.Count
   If Pfad = "" Then Exit Sub
   d = a.DateilisteErstellen(Pfad)
   For Zähler = 1 To UBound(d)
      Zielbereich(1) = d(Zähler)(1)
      Zielbereich(2) = d(Zähler)(2)
      Zielbereich(3) = d(Zähler)(3)
      Zielbereich(4) = Format$(d(Zähler)(4), "DD.MM.YYYY hh:nn:ss")
      Zielbereich(5) = Format$(d(Zähler)(5), "DD.MM.YYYY hh:nn:ss")
      Zielbereich(6) = Format$(d(Zähler)(6), "DD.MM.YYYY hh:nn:ss")
      Zielbereich(7) = d(Zähler)(7)
      Err.Clear
      .Range(Cells(Zähler + 5, 1), Cells(Zähler + 5, 7)) = Zielbereich
      If Err.Number <> 0 Then
          Zielbereich(1) = "'" & Zielbereich(1)
          Zielbereich(2) = "'" & Zielbereich(2)
          Zielbereich(3) = "'" & Zielbereich(3)
          .Range(Cells(Zähler + 5, 1), Cells(Zähler + 5, 7)) = Zielbereich
      End If
   Next
End With
End Sub

'##############################################
'# Ein Klassenmodul mit dem Namen clsVerzeichnisbaum
'##############################################

Option Explicit
Private Declare Function FindClose Lib "kernel32" _
    (ByVal hFindFile As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" _
    Alias "FindFirstFileA" (ByVal lpFileName As String, _
    lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" _
    Alias "FindNextFileA" (ByVal hFindFile As Long, _
    lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" _
    (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const MAX_PATH = 260
Private Type SYSTEMTIME
        wYear As Integer
        wMonth As Integer
        wDayOfWeek As Integer
        wDay As Integer
        wHour As Integer
        wMinute As Integer
        wSecond As Integer
        wMilliseconds As Integer
End Type
Private Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
        dwFileAttributes As Long
        ftCreationTime As FILETIME
        ftLastAccessTime As FILETIME
        ftLastWriteTime As FILETIME
        nFileSizeHigh As Long
        nFileSizeLow As Long
        dwReserved0 As Long
        dwReserved1 As Long
        cFileName As String * MAX_PATH
        cAlternate As String * 14
End Type
Private iDateiliste(), myIndex As Long

Public Function DateilisteErstellen(Startpfad As String)
On Error Resume Next
    ReDim iDateiliste(1 To 1000)
    DurchlaufePfad Startpfad
    If myIndex = 0 Then
        ReDim iDateiliste(0)
    Else
        ReDim Preserve iDateiliste(1 To myIndex)
    End If
    DateilisteErstellen = iDateiliste
End Function

Private Function DurchlaufePfad(ByVal Pfadname As String) As Currency
Dim Suchhandle As Long, Rück As Long
Dim Suchkriterium As String
Dim Filedaten As WIN32_FIND_DATA
Dim strFileName As String, strDosName As String
Dim Eigenschaft(1 To 7)
Dim Verzeichnisgröße As Currency
'Führende und nachfolgende Leerzeichen entfernen
Pfadname = Trim(Pfadname)
'Wenn nötig, Backslash anhängen
If Right$(Pfadname, 1) <> "\" Then
    Pfadname = Pfadname & "\"
End If
'Alle Dateien suchen
Suchkriterium = Pfadname & "*"
With Filedaten
    .cAlternate = String(14, Chr(0))
    .cFileName = String(260, Chr(0))
    'Erstes Filehandle auf dieser Ebene ermitteln
    Suchhandle = FindFirstFile(Suchkriterium, Filedaten)
    Rück = Suchhandle
    Do While Rück <> 0
        'Datei gefunden
        Verzeichnisgröße = 0
        strFileName = StrSpaceNullTrim(.cFileName)
        strDosName = StrSpaceNullTrim(.cAlternate)
        If strFileName <> ".." And strFileName <> "." Then
            'Directory oder File gefunden.
            'Vorheriges Verzeichnis (.), oder Wurzelverzeichnis (..)
            'ignorieren
            If (.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
                'Rekursiver Aufruf, wenn Unterverzeichnis
                Verzeichnisgröße = DurchlaufePfad((Pfadname & strFileName))
            Else
                'Datei gefunden, Infos in Array Eigenschaft kopieren
                Eigenschaft(1) = strFileName
                If Len(strDosName) = 0 Then strDosName = strFileName
                Eigenschaft(2) = strDosName
                Eigenschaft(3) = Pfadname
                Eigenschaft(4) = Zeitumwandlung(.ftCreationTime)
                Eigenschaft(5) = Zeitumwandlung(.ftLastAccessTime)
                Eigenschaft(6) = Zeitumwandlung(.ftLastWriteTime)
                Eigenschaft(7) = .nFileSizeLow
                myIndex = myIndex + 1
                'Wenn mehr Dateien vorhanden, als iDateiliste
                'aufnehmen kan, Array Redimensionieren und Werte
                'beibehalten
                If myIndex > UBound(iDateiliste) Then _
                    ReDim Preserve iDateiliste(1 To myIndex + 1000)
                iDateiliste(myIndex) = Eigenschaft
            End If
        End If
        .cAlternate = String(14, Chr(0))
        .cFileName = String(260, Chr(0))
        'Nächste Datei
        Rück = FindNextFile(Suchhandle, Filedaten)
    Loop
End With
FindClose Suchhandle
End Function

Private Function StrSpaceNullTrim(X As String) As String
    StrSpaceNullTrim = Trim(Left(X, InStr(1, X, Chr(0)) - 1))
End Function

Private Function Zeitumwandlung(Filezeit As FILETIME) As Date
Dim S_Zeit As SYSTEMTIME
'Umwandlung Filezeit in Systemzeit
FileTimeToSystemTime Filezeit, S_Zeit
If S_Zeit.wYear >= 1900 Then
    Zeitumwandlung = CDbl(DateSerial(S_Zeit.wYear, _
    S_Zeit.wMonth, S_Zeit.wDay) _
    + TimeSerial(S_Zeit.wHour, S_Zeit.wMinute, S_Zeit.wSecond))
Else
    Zeitumwandlung = 0
End If
End Function