Tipp 0068 Ordner-Informationen (extended)
Autor/Einsender:
Datum:
  Detlev Schubert
27.05.2001
Entwicklungsumgebung:   VB 5
Damit von einem Ordner (Verzeichnis) auch noch sämtliche Unterordner inkl. der dort enthaltenen Dateien ermittelt werden können, müssen wir schon richtig schweres Geschütz auffahren. Hier wird mittels eines rekursiven Suchalgorithmus der gesamte Ordner gescannt. Wenn nur die in einem Ordner enthaltenen Dateien, mit Umfang (Verzeichnisgröße in kByte) benötigt werden, reicht in der Regel auch der Tipp Ordner-Informationen.
 
Option Explicit

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 FindClose Lib "kernel32" (ByVal _
        hFindFile As Long) As Long

Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type

Const MAX_PATH = 259

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

Const FILE_ATTRIBUTE_ARCHIVE = &H20
Const FILE_ATTRIBUTE_COMPRESSED = &H800
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Const FILE_ATTRIBUTE_HIDDEN = &H2
Const FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_ATTRIBUTE_READONLY = &H1
Const FILE_ATTRIBUTE_SYSTEM = &H4
Const FILE_ATTRIBUTE_TEMPORARY = &H100

Private Sub Form_Load()
  Dir1_Change
End Sub

Private Sub Dir1_Change()
  Dim Dateien() As String, x As Long
  Dim Datei As Integer, Ordner As Integer, Groesse As Long
  Dim Pfad As String, Alle As String

  Screen.MousePointer = vbHourglass

  Label1(1).Caption = ""
  Label1(3).Caption = ""
  Label1(5).Caption = ""
  Label1(7).Caption = ""
  Label1(8).Caption = "Inhalt von: " & vbCrLf & Dir1.Path

  Pfad = Dir1.Path
  Alle = "*.*"
  ReDim Dateien(0 To 0)
  DoEvents
  GetAllFiles Pfad, Alle, Dateien

  For x = 0 To UBound(Dateien) - 1
    If Left$(Dateien(x), 1) = "°" Then
      Ordner = Ordner + 1
    Else
      Groesse = Groesse + FileLen(Trim$(Dateien(x)))
      Datei = Datei + 1
    End If
  Next x

  Label1(1).Caption = Format$(Ordner, "###,##0") & " "
  Label1(3).Caption = Format$(Datei, "###,##0") & " "
  Label1(5).Caption = Format$(Groesse, "###,##0") & " "
  Label1(7).Caption = Format$((Groesse / 1024) / 1024, _
      "###,##0.00") & " "
  Screen.MousePointer = 0
End Sub

Private Sub Drive1_Change()
  Dir1.Path = Drive1.Drive
End Sub

Private Sub GetAllFiles(ByVal Pfad As String, ByVal Patt$, _
      ByRef Field() As String)

  Dim Datei$, hFile&, FD As WIN32_FIND_DATA

  If Right(Pfad, 1) <> "\" Then Pfad = Pfad & "\"
  hFile = FindFirstFile(Pfad & Patt, FD)
  If hFile = 0 Then Exit Sub

  Do
    Datei = Left(FD.cFileName, InStr(FD.cFileName, Chr(0)) - 1)
    If (FD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) _
        = FILE_ATTRIBUTE_DIRECTORY Then
      If (Datei <> ".") And (Datei <> "..") Then
        Field(UBound(Field)) = "°" & Pfad & Datei
        ReDim Preserve Field(0 To UBound(Field) + 1)
        GetAllFiles Pfad & Datei, Patt, Field
      End If
    Else
      Field(UBound(Field)) = Pfad & Datei
      ReDim Preserve Field(0 To UBound(Field) + 1)
    End If
  Loop While FindNextFile(hFile, FD)

  FindClose hFile
End Sub
 
Weitere Links zum Thema
Rekursives Suchen von Dateien (API)
Rekursives Suchen von Dateien (FSO)

Windows-Version
95
98/SE
ME
NT
2000
XP
Vista
Win 7
VB-Version
VBA 5
VBA 6
VB 4/16
VB 4/32
VB 5
VB 6


Download  (3 kB) Downloads bisher: [ 2306 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Mittwoch, 31. August 2011