'********************************************************************************
'*                                                                              *
'*    Klassenmodul cFindFile                                                    *
'*                                                                              *
'*    Rekursive Dateisuche über die API´s FindFirstFile, FindNextFile.          *
'*                                                                              *
'*    Flexibles Klassenmodul ohne Anbindung an ein Steuerelement. Die           *
'*    gefundene Datei wird sofort über den Event "MatchFound" zurückgegeben.    *
'*    Daher wird kein dynamisches Array zum speichern der Suchergebnisse        *
'*    benötigt. Folgende Eigenschaften, Methoden und Ereignisse stehen          *
'*    zur Verfügung:                                                            *
'*                                                                              *
'*    Eigenschaften:                                                            *
'*       sSearchpath       -> (String) Startverzeichnis                         *
'*       sFileToFind       -> (String) zu suchende Datei incl. Wildcards *?     *
'*       sFileFlag         -> (Enum FileFlag) Dateieigenschaften sFileToFind    *
'*       sInclSubfolders   -> (Boolean) Suche mit Unterverzeichnisse            *
'*                                                                              *
'*    Methoden:                                                                 *
'*       sStartSearch()    -> Startet den Suchlauf                              *
'*                                                                              *
'*    Ereignisse:                                                               *
'*       MatchFound        -> Liefert den gefundenen Treffer direkt zurück.     *
'*                            Übergeben werden Name, Pfad, Datum ,Größe,        *
'*                            letzter Zugriff, letztes Speicherdatum und        *
'*                            DOS Kurzname (8.3)                                *
'*       StopSearch        -> Boolean, bestimmt den Suchabbruch.                *
'*                                                                              *
'*                                                                              *
'*    Mai 2003 - Roland Wutzke      mailto:rwutzke@t-online.de                  *
'*                                                                              *
'********************************************************************************

Option Explicit

' Benötigte API´s
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 Declare Function FileTimeToSystemTime Lib "kernel32" _
   (lpFileTime As FILETIME, _
   lpSystemTime As SYSTEMTIME) As Long


' Benutzerdefinierte Konstanten
Private Const MAX_PATH = 260
Private Const MAXDWORD = &HFFFF
Private Const INVALID_HANDLE_VALUE = -1
Private Const MyUnhandledError = 9999


' Benutzerdefinierte Typen
Private Type FILETIME
   dwLowDateTime As Long
   dwHighDateTime As Long
End Type

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


' Aufzählung für sFileFlag Eigenschaft
Public Enum FileFlag
   FILE_ATTRIBUTE_READONLY = &H1
   FILE_ATTRIBUTE_HIDDEN = &H2
   FILE_ATTRIBUTE_SYSTEM = &H4
   FILE_ATTRIBUTE_DIRECTORY = &H10
   FILE_ATTRIBUTE_ARCHIVE = &H20
   FILE_ATTRIBUTE_NORMAL = &H80
   FILE_ATTRIBUTE_TEMPORARY = &H100
   FILE_ATTRIBUTE_ALLTYPES = &H1B7
   FILE_ATTRIBUTE_ALLTYPES_WITHOUT_DIR = &H1A7
End Enum


'lokale Variablen zum Zuweisen der Eigenschaften
Private mvarsSearchpath As String
Private mvarsFileToFind As String
Private mvarsInclSubfolders As Boolean
Private mvarsFileFlag As FileFlag


'RaiseEvent MatchFound[(arg1, arg2, ... , argn)]
Public Event MatchFound(ByVal sFilename As String, _
   ByVal sFilePath As String, _
   ByVal sFiledate As Date, _
   ByVal sFilesize As Long, _
   ByVal sLastAccess As Date, _
   ByVal sLastWrite As Date, _
   ByVal sShortName As String)
   
'RaiseEvent StopSearch[(arg1)]
Public Event StopSearch(Cancel As Boolean)

Private Sub Class_Initialize()
   'Die Klasse wird initialisiert.
   sFileFlag = FILE_ATTRIBUTE_ALLTYPES
   sInclSubfolders = True
End Sub

Private Sub Class_Terminate()
   'Die Klasse wird aus dem Speicher entfernt.
End Sub

Public Sub sStartSearch()
   Dim lFileToFind As String, lSearchpath As String, FileName As String
   Dim ShortName As String, DirName As String, DirNames() As String
   Dim DirCount As Integer, nDir As Integer, Cont As Integer, I As Integer
   Dim Filesize As Long, hSearch As Long
   Dim Filedate As Date, LastAccess As Date, LastWrite As Date
   Dim lInclSubfolders As Boolean, bCancel As Boolean
   Dim sDate As SYSTEMTIME
   Dim lFileFlag As FileFlag
   Dim WFD As WIN32_FIND_DATA
   
   On Error GoTo sStartSearchErr
   
   ' Eigenschaften Property Get in lokale Variablen kopieren
   lFileToFind = sFileToFind
   lFileFlag = sFileFlag
   lSearchpath = sSearchpath
   lInclSubfolders = sInclSubfolders
    
   ' Initialisieren der Variablen
   If Right(lSearchpath, 1) <> "\" Then lSearchpath = lSearchpath & "\"
   nDir = 0
   DirCount = 0
   ReDim DirNames(nDir)
   Cont = True
   bCancel = False
   
   ' Die Suche geht los. Zuerst werden die Subfolders ermittelt
   hSearch = FindFirstFile(lSearchpath & "*", WFD)
   If hSearch <> INVALID_HANDLE_VALUE Then
      Do While Cont
         ' vbNullChar entfernen
         DirName = Left$(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)
         
         ' Prüfen, ob DirName auch wirklich ein Subfolder ist
         If (DirName <> ".") And (DirName <> "..") Then
            If (WFD.dwFileAttributes And vbDirectory) = FileFlag.FILE_ATTRIBUTE_DIRECTORY Then
                
                ' Subfolder ins loakale Array speichern
                DirNames(nDir) = DirName
                
                ' Schleifenzähler erhöhen
                DirCount = DirCount + 1
                nDir = nDir + 1
                
                ' Lokales Array neu dimensionieren
                ReDim Preserve DirNames(nDir)
            End If
         End If
         
         ' Nächster Subfolder ermitteln
         Cont = FindNextFile(hSearch, WFD)
         
         ' Geben wir der Methode ein wenig Zeit zum Atmen
         DoEvents
      Loop
      Cont = FindClose(hSearch)
   End If

   ' Jetzt werden die zu findenden Dateien ermittelt
   hSearch = FindFirstFile(lSearchpath & lFileToFind, WFD)
   Cont = True
   If hSearch <> INVALID_HANDLE_VALUE Then
      While Cont
         ' vbNullChar entfernen
         FileName = Left$(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)
         
         ' Prüfen, ob FileName ungleich . und .. ist
         If (FileName <> ".") And (FileName <> "..") Then
            ' Stimmt das FileAttribut mit Eigenschaft sFileFlag überein
            If (WFD.dwFileAttributes Or lFileFlag) = lFileFlag Then
               
               ' Dateigröße ermitteln
               Filesize = (WFD.nFileSizeHigh * MAXDWORD) + WFD.nFileSizeLow
               
               ' Dateidatum/Zeit ermitteln
               FileTimeToSystemTime WFD.ftCreationTime, sDate
               With sDate
                  Filedate = CDate(.wDay & "." & .wMonth & "." & .wYear _
                     & " " & .wHour & ":" & .wMinute & ":" & .wSecond)
               End With
               
               ' LastAccess ermitteln
               FileTimeToSystemTime WFD.ftLastAccessTime, sDate
               With sDate
                  LastAccess = CDate(.wDay & "." & .wMonth & "." & .wYear _
                     & " " & .wHour & ":" & .wMinute & ":" & .wSecond)
               End With
               
               ' LastWrite ermitteln
               FileTimeToSystemTime WFD.ftLastWriteTime, sDate
               With sDate
                  LastWrite = CDate(.wDay & "." & .wMonth & "." & .wYear _
                     & " " & .wHour & ":" & .wMinute & ":" & .wSecond)
               End With
               
               ' ShortName 8.3 ermitteln
               ShortName = Left$(WFD.cAlternate, InStr(WFD.cAlternate, vbNullChar) - 1)
               
               ' Und jetzt den Event aufrufen um die Dateiinformationen zu übergeben
               RaiseEvent MatchFound(FileName, lSearchpath, Filedate, Filesize, _
                                     LastAccess, LastWrite, ShortName)
            End If
         End If
                  
         ' Nächste Datei ermitteln
         Cont = FindNextFile(hSearch, WFD)
         
         ' Geben wir der Methode ein wenig Zeit zum Atmen
         DoEvents
      Wend
      ' Suche abgeschlossen
      Cont = FindClose(hSearch)
   End If
   
   ' Sollen die Subfolders durchsucht werden?
   If lInclSubfolders Then
      ' Prüfen, ob im aktuellen Folder weitere Subfolder sind
      If nDir > 0 Then
         ' Rekursiver Aufruf der Methode mit Übergabe eines neuen Subfolders
         For I = 0 To nDir - 1
            ' Event StopSearch aufrufen und prüfen ob Abbruch
            ' durch Benutzer erfolgte
            RaiseEvent StopSearch(bCancel)
            If bCancel Then Exit Sub
            
            ' neuer Suchpfad an Property Let sSearchpath übergeben
            sSearchpath = lSearchpath & DirNames(I)
            ' neue Suche starten...
            sStartSearch
         Next I
      End If
   End If
Exit Sub

sStartSearchErr:
   RaiseError MyUnhandledError, "cFindFile:sStartSearch Method" _
      , "Fehler bei sStartSearch"
End Sub

' Eigenschaft cFindFile.sFileFlag setzen
Public Property Let sFileFlag(ByVal vData As FileFlag)
   On Error GoTo sFileFlagLetErr
   mvarsFileFlag = vData
Exit Property

sFileFlagLetErr:
   RaiseError MyUnhandledError, "cFindFile:sFileFlag Property Let" _
      , "Fehler bei sFileFlag Property Let"
End Property

' Eigenschaft cFindFile.sFileFlag lesen
Public Property Get sFileFlag() As FileFlag
   On Error GoTo sFileFlagGetErr
   sFileFlag = mvarsFileFlag
Exit Property

sFileFlagGetErr:
   RaiseError MyUnhandledError, "cFindFile:sFileFlag Property Get" _
      , "Fehler bei sFileFlag Property Get"
End Property

' Eigenschaft cFindFile.sInclSubFolders setzen
Public Property Let sInclSubfolders(ByVal vData As Boolean)
   On Error GoTo sInclSubfoldersLetErr
   mvarsInclSubfolders = vData
Exit Property

sInclSubfoldersLetErr:
   RaiseError MyUnhandledError, "cFindFile:sInclSubfolders Property Let" _
      , "Fehler bei sInclSubfolders Property Let"
End Property

' Eigenschaft cFindFile.sInclSubFolders lesen
Public Property Get sInclSubfolders() As Boolean
Attribute sInclSubfolders.VB_UserMemId = 0
   On Error GoTo sInclSubfoldersGetErr
   sInclSubfolders = mvarsInclSubfolders
Exit Property

sInclSubfoldersGetErr:
   RaiseError MyUnhandledError, "cFindFile:sInclSubfolders Property Get" _
      , "Fehler bei sInclSubfolders Property Get"
End Property

' Eigenschaft cFindFile.sFileToFind setzen
Public Property Let sFileToFind(ByVal vData As String)
   On Error GoTo sFileToFindLetErr
   mvarsFileToFind = vData
Exit Property

sFileToFindLetErr:
   RaiseError MyUnhandledError, "cFindFile:sFileToFind Property Let" _
      , "Fehler bei sFileToFind Property Let"
End Property

' Eigenschaft cFindFile.sFileToFind lesen
Public Property Get sFileToFind() As String
   On Error GoTo sFileToFindGetErr
   sFileToFind = mvarsFileToFind
Exit Property

sFileToFindGetErr:
   RaiseError MyUnhandledError, "cFindFile:sFileToFind Property Get" _
    , "Fehler bei sFileToFind Property Get"
End Property

' Eigenschaft cFindFile.sSearchpath setzen
Public Property Let sSearchpath(ByVal vData As String)
   On Error GoTo sSearchpathLetErr
   mvarsSearchpath = vData
Exit Property

sSearchpathLetErr:
   RaiseError MyUnhandledError, "cFindFile:sSearchpath Property Let" _
      , "Fehler bei sSearchpath Property Let"
End Property

' Eigenschaft cFindFile.sSearchpath lesen
Public Property Get sSearchpath() As String
   On Error GoTo sSearchpathGetErr
   sSearchpath = mvarsSearchpath
Exit Property

sSearchpathGetErr:
   RaiseError MyUnhandledError, "cFindFile:sSearchpath Property Get" _
      , "Fehler bei sSearchpath Property Get"
End Property

' Error Object setzen und an den Client übergeben
Private Sub RaiseError(ErrorNumber As Long, Source As String, strErrorText As String)
   Err.Raise ErrorNumber, Source, strErrorText
End Sub