Zurück zur Homepage

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 LongAs 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 StringAs 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 StringAs 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