Re: verzeichnisse ermitteln
26.05.2002 15:24:23
Edgar Kälin
Folgende Prozeduren und Funktionen listen Dir Verzeichnnisse, Dateien etc. in einer Tabelle auf: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
Sub DateilisteErstellen()
Dim Dateiliste, Zähler&, Pfad$, AnzahlDateien&
Dim Zähler1, Zielbereich(1 To 8), Überschrift
On Error GoTo Fehlerbehandlung
Pfad = c:\
Überschrift = Array("Datei", "Dos-Name", "Pfad", "Kompletter Pfad", _
"Erstellungszeitpunkt", "Letzter Zugriff", "Letzter Schreibzugriff", "Größe")
With Sheets("Liste")
.Cells.ClearContents
For Zähler1 = 1 To 8
.Cells(1, Zähler1) = Überschrift(Zähler1 - 1)
Next
AnzahlDateien = DurchlaufePfad(Pfad, Dateiliste)
Application.ScreenUpdating = True
For Zähler = 1 To AnzahlDateien
For Zähler1 = 1 To 8
Zielbereich(Zähler1) = Dateiliste(Zähler1, Zähler)
Next
.Range(.Cells(Zähler + 1, 1), .Cells(Zähler + 1, 8)) = Zielbereich
Next
End With
Fehlerbehandlung:
Application.ScreenUpdating = True
End Sub
Private Function DurchlaufePfad(ByVal Pfadname As String, Dateiliste, Optional Dateiindex As Long) As Long
Dim Suchhandle&, Rückgabewert1&, dummy
Dim Suchkriterium$, zeile&, Erstellungsdatum As Date
Dim Filedaten As WIN32_FIND_DATA
If Dateiindex = 0 Then Dateiindex = 1
dummy = TypeName(Dateiliste)
Select Case dummy
Case "Variant()"
If UBound(Dateiliste, 1) <> 8 Then
ReDim Dateiliste(1 To 8, 1 To 10000)
End If
Case "Empty"
ReDim Dateiliste(1 To 8, 1 To 10000)
Case Else
Exit Function
End Select
Pfadname = Trim(Pfadname)
If Right$(Pfadname, 1) = "\" Then
Suchkriterium = Pfadname & "*"
Else
Suchkriterium = Pfadname & "\*"
End If
zeile = Dateiindex
Filedaten.cAlternate = String(14, Chr(0))
Filedaten.cFileName = String(260, Chr(0))
Suchhandle = FindFirstFile(Suchkriterium, Filedaten)
Rückgabewert1 = Suchhandle
Do While Rückgabewert1 <> 0
Filedaten.cFileName = Left(Filedaten.cFileName, InStr(1, Filedaten.cFileName, Chr(0)) - 1)
Filedaten.cAlternate = Left(Filedaten.cAlternate, InStr(1, Filedaten.cAlternate, Chr(0)) - 1)
If Trim(Filedaten.cFileName) <> "." And Trim(Filedaten.cFileName) <> ".." Then
If Filedaten.dwFileAttributes = FILE_ATTRIBUTE_DIRECTORY Then
zeile = DurchlaufePfad((Pfadname & "\" & Trim(Filedaten.cFileName)), Dateiliste, zeile)
End If
If zeile = UBound(Dateiliste, 2) Then ReDim Preserve Dateiliste(1 To 8, 1 To zeile + 1000)
Dateiliste(1, zeile) = Trim(Filedaten.cFileName)
Dateiliste(2, zeile) = Trim(Filedaten.cAlternate)
Dateiliste(3, zeile) = Pfadname
Dateiliste(4, zeile) = Pfadname & "\" & Dateiliste(1, zeile)
Dateiliste(5, zeile) = Zeitumwandlung(Filedaten.ftCreationTime)
Dateiliste(6, zeile) = Zeitumwandlung(Filedaten.ftLastAccessTime)
Dateiliste(7, zeile) = Zeitumwandlung(Filedaten.ftLastWriteTime)
Dateiliste(8, zeile) = Filedaten.nFileSizeLow
zeile = zeile + 1
End If
Filedaten.cAlternate = String(14, Chr(0))
Filedaten.cFileName = String(260, Chr(0))
Rückgabewert1 = FindNextFile(Suchhandle, Filedaten)
Loop
DurchlaufePfad = zeile
dummy = FindClose(Suchhandle)
End Function
Private Function Zeitumwandlung(Filezeit As FILETIME)
Dim S_Zeit As SYSTEMTIME
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 = ""
End If
End Function
Mfg
Edgar