Rubrik: Excel | VB-Versionen: VBA | 03.01.05 |
Dateiliste mit/ohne Unterverzeichnisse mit Klasse Dateien (alle bzw. bestimmter Dateityp) und deren Eigenschaften werden aus einem Verzeichnis (mit/ohne Unterordner) in ein Datenfeld gelesen. | ||
Autor: Friedrich Grath | Bewertung: | Views: 26.242 |
ohne Homepage | System: Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 | kein Beispielprojekt |
Man wählt mittels Ordnerauswahl-Dialog (Vorselektion möglich) ein Verzeichnis. Mit Hilfe eines Klassenmoduls (clsVerzeichnisbaum) werden in diesem Verzeichnis - wahlweise mit/ohne Unterordner - Dateien gesucht. Die Suche nach alle Dateien oder nur nach einem bestimmten Dateityp ist möglich.
Von den gefundenen Dateien werden folgende Eigenschaften ausgelesen:
- Dateiname
- Dos-Name
- Pfad/Verzeichnis
- Erstellungsdatum
- letzter Zugriff
- letzter Schreibzugriff
- Dateigröße
Diese Eigenschaften werden in dem zweidimensionalen Datenfeld datEigenschaft() gespeichert. Anschließend werden die gefundenen Eigenschaften in einem neuen Tabellenblatt ausgegeben. Das Programm kann mehrfach hintereinander verwendet werde, dabei wird jedesmal eine neue Ergebnisliste erstellt.
Das Datenfeld kann aber auch anderwertig verwendet werden (z.B. nur die Dateinamen in einer ListBox anzeigen). Funktioniert auch in anderen Anwendungen (VB).
Nachfolgenden Code bitte in ein Modul einfügen:
' MODUL--------------------------------------------------------------------------- ' Name: Dateiliste Option Explicit ' Benötigte API-Deklarationen Private Type BrowseInfo hWndOwner As Long pIDLRoot As Long pszDisplayName As Long lpszTitle As Long ulFlags As Long lpfnCallback As Long lParam As Long iImage As Long End Type Private Const MAX_PATH = 260 Private Const BIF_RETURNONLYFSDIRS = &H1 Private Const BFFM_SETSELECTION = &H466 Private Const BFFM_INITIALIZED = 1 Private Declare Sub CoTaskMemFree Lib "ole32.dll" ( _ ByVal hMem As Long) Private Declare Function lstrcat Lib "kernel32" _ Alias "lstrcatA" ( _ ByVal lpString1 As String, _ ByVal lpString2 As String) As Long Private Declare Function GetActiveWindow Lib "user32" () As Long Private Declare Function SHGetPathFromIDList Lib "shell32" ( _ ByVal pidList As Long, _ ByVal lpBuffer As String) As Long Private Declare Function SHBrowseForFolder Lib "shell32" ( _ lpbi As BrowseInfo) As Long Private Declare Function SendMessage Lib "user32.dll" _ Alias "SendMessageA" ( _ ByVal hWnd As Long, _ ByVal Msg As Long, _ wParam As Any, _ lParam As Any) As Long Private m_BrowseInitDir As String Public datEigenschaft() Public datGesGröße As Long
' Aufruf-Routine ' Vorgabewerte mit '##### gekennzeichnet Sub Datei_Eigenschaften() Dim sPath As String Dim clsKlasse As New clsVerzeichnisbaum Dim Pfad As String Dim DateiTyp As String Dim blattName As String Dim Zähler As Long Dim n As Integer Dim d As Variant ' ##### Ordnerauswahldialog mit Vorselektion Pfad = OrdnerAuswählen("Bitte Ordner auswählen", "C:\temp") ' Anwendung verlassen, wenn kein Verzeichnis ausgewählt wurde If Pfad = "" Then Exit Sub ' ##### festlegen , welcher Dateityp gesucht wird ('*' - alle Dateien) DateiTyp = "xls" 'für Exceldatei ' ##### Aufruf des Klassenmoduls 'clsVerzeichnisbaun' ' bei TRUE werden die Unterverzeichnisse mit durchsucht d = clsKlasse.DateilisteErstellen(Pfad, DateiTyp, False) ' neu dimensionieren ReDim datEigenschaft(1 To 7, 1 To UBound(d)) ' Dateieigenschaften in die Variable datEigenschaft() schreiben For Zähler = 1 To UBound(d) ' Dateiname datEigenschaft(1, Zähler) = d(Zähler)(1) ' DOS-Name datEigenschaft(2, Zähler) = d(Zähler)(2) ' Pfad datEigenschaft(3, Zähler) = d(Zähler)(3) ' Erstellungszeitpunkt datEigenschaft(4, Zähler) = Format(d(Zähler)(4), "DD.MM.YYYY hh:nn:ss") ' letzter Zugriff datEigenschaft(5, Zähler) = Format(d(Zähler)(5), "DD.MM.YYYY hh:nn:ss") ' letzter Schreibzugriff datEigenschaft(6, Zähler) = Format(d(Zähler)(6), "DD.MM.YYYY hh:nn:ss") ' Größe datEigenschaft(7, Zähler) = d(Zähler)(7) Next ' Abschnitt 'Augabe in ein neues Tabellenblatt' ' Dieser Abschnitt kann entfallen, wenn die Dateiliste datEigenschaft() ' anders verwendet wird (z.B. Liste in eine ComboBox ausgeben) For n = Sheets.Count To 1 Step -1 If InStr(Sheets(n).Name, "Dateiliste_") Then Sheets.Add after:=Worksheets(n) blattName = "Dateiliste_" & _ CInt(Right(Sheets(n).Name, Len(Sheets(n).Name) - 11) + 1) ActiveSheet.Name = blattName GoTo Weiter End If Next n Sheets.Add after:=Worksheets(1) blattName = "Dateiliste_1" ActiveSheet.Name = "Dateiliste_1" Weiter: Application.ScreenUpdating = False With Sheets(blattName) .Cells(5, 1) = "Dateiname" .Cells(5, 2) = "Dos-Name" .Cells(5, 3) = "Pfad/Verzeichnis" .Cells(5, 4) = "Erstellt" .Cells(5, 5) = "letzter Zugriff" .Cells(5, 6) = "letzter Schreibzugriff" .Cells(5, 7) = "Dateigröße" For Zähler = 1 To UBound(d) .Cells(Zähler + 5, 1) = datEigenschaft(1, Zähler) .Cells(Zähler + 5, 2) = datEigenschaft(2, Zähler) .Cells(Zähler + 5, 3) = datEigenschaft(3, Zähler) .Cells(Zähler + 5, 4) = datEigenschaft(4, Zähler) .Cells(Zähler + 5, 5) = datEigenschaft(5, Zähler) .Cells(Zähler + 5, 6) = datEigenschaft(6, Zähler) .Cells(Zähler + 5, 7) = datEigenschaft(7, Zähler) Next .Range(.Cells(1, 1), .Cells(Zähler + 6, 7)).Font.Name = "Tahoma" .Range(.Cells(1, 1), .Cells(Zähler + 6, 7)).Font.Size = 8 .Range(.Cells(5, 1), .Cells(5, 7)).Font.Bold = True .Range(.Cells(5, 1), .Cells(5, 7)).Font.ColorIndex = 5 .Cells(1, 1) = "DATEILISTE" .Cells(1, 1).Font.Bold = True .Cells(1, 1).Font.ColorIndex = 5 .Range(.Cells(5, 1), .Cells(5, 7)).Font.ColorIndex = 5 .Cells(Zähler + 6, 6) = "Gesamt" .Cells(Zähler + 6, 7) = datGesGröße .Range(.Cells(6, 7), .Cells(Zähler + 6, 7)).NumberFormat = "#,##0" .Range(.Cells(Zähler + 7, 6), .Cells(Zähler + 6, 7)).Font.Bold = True .Columns("A:G").AutoFit .Range("A5:G5").AutoFilter .Cells(3, 1) = "Verzeichnis: " & Pfad .Cells(1, 1).Font.Size = 14 .Cells(3, 1).Font.Bold = True .Cells(3, 1).Font.Size = 10 End With Application.ScreenUpdating = True End Sub
' Ordnerauswahl-Dialog mit optionaler Angabe eines Startverzeichnisses Public Function OrdnerAuswählen(ByVal sPrompt As String, _ Optional ByVal sInitDir As String) As String Dim nPos As Long Dim nIDList As Long Dim sPath As String Dim oInfo As BrowseInfo m_BrowseInitDir = sInitDir ' Datenstruktur füllen With oInfo .hWndOwner = GetActiveWindow() .lpszTitle = lstrcat(sPrompt, "") .ulFlags = BIF_RETURNONLYFSDIRS If sInitDir <> "" Then ' Callback-Funktionsadresse .lpfnCallback = FuncCallback(AddressOf BrowseCallback) End If End With ' Dialog anzeigen und auswerten nIDList = SHBrowseForFolder(oInfo) If nIDList Then sPath = String$(MAX_PATH, 0) Call SHGetPathFromIDList(nIDList, sPath) Call CoTaskMemFree(nIDList) nPos = InStr(sPath, vbNullChar) If nPos Then sPath = Left$(sPath, nPos - 1) End If OrdnerAuswählen = sPath End Function
Private Function BrowseCallback(ByVal hWnd As Long, _ ByVal uMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long Select Case uMsg Case BFFM_INITIALIZED ' Start-Ordner Call SendMessage(hWnd, BFFM_SETSELECTION, ByVal 1&, _ ByVal m_BrowseInitDir) End Select BrowseCallback = 0 End Function
' Hilfsfunktion für AddressOf Private Function FuncCallback(ByVal nParam As Long) As Long FuncCallback = nParam End Function ' --------------------------------------------------------------------------------
Nachfolgenden Code in ein Klassenmodul einfügen:
' KLASSENMODUL --------------------------------------------------------- ' Name: clsVerzeichnisbaum Option Explicit ' benötigte API-Deklarationen 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() Private myIndex As Long
Private Function DurchlaufePfad(ByVal Pfadname As String, _ ByVal Erweiterung As String, _ ByVal Verzeichnis As Boolean) As Currency Dim Suchhandle As Long, Rück As Long Dim Filedaten As WIN32_FIND_DATA Dim Suchkriterium As String Dim strFileName As String Dim strDosName As String Dim Verzeichnisgröße As Currency Dim Eigenschaft(1 To 7) ' Führende und nachfolgende Leerzeichen entfernen Pfadname = Trim(Pfadname) ' Wenn nötig, Backslash anhängen If Right$(Pfadname, 1) <> "\" Then Pfadname = Pfadname & "\" ' Alle Dateien suchen Suchkriterium = Pfadname & "*" ' für alle Dateien 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 And _ Verzeichnis = True Then ' Rekursiver Aufruf, wenn Unterverzeichnis Verzeichnisgröße = DurchlaufePfad((Pfadname & strFileName), Erweiterung, Verzeichnis) Else ' Passt das Suchmuster? If Erweiterung = Right(strFileName, Len(Erweiterung)) Or Erweiterung = "*" Then ' Datei 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 datGesGröße = datGesGröße + Eigenschaft(7) myIndex = myIndex + 1 ' Wenn mehr Dateien vorhanden, als iDateiliste aufnehmen ' kann, Array Redimensionieren und Werte beibehalten If myIndex > UBound(iDateiliste) Then _ ReDim Preserve iDateiliste(1 To myIndex + 1000) iDateiliste(myIndex) = Eigenschaft End If 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
Public Function DateilisteErstellen(Startpfad As String, _ Erweiterung As String, _ Unterverzeichnis As Boolean) On Error Resume Next ReDim iDateiliste(1 To 1000) DurchlaufePfad Startpfad, Erweiterung, Unterverzeichnis If myIndex = 0 Then ReDim iDateiliste(0) Else ReDim Preserve iDateiliste(1 To myIndex) End If DateilisteErstellen = iDateiliste 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 ' ----------------------------------------------------------------------