vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
vb@rchiv Offline-Reader - exklusiv auf der vb@rchiv CD Vol.4  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2021
 
zurück
Rubrik: Excel   |   VB-Versionen: VBA03.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 GrathBewertung:     [ Jetzt bewerten ]Views:  24.741 
ohne HomepageSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10kein 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
' ----------------------------------------------------------------------

Dieser Tipp wurde bereits 24.741 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
   

Druckansicht Druckansicht Copyright ©2000-2021 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel