Option Explicit
 
Dim fso As New FileSystemObject
Dim fld As Folder
 
Private Sub cmdFSuchen_Click()
   Dim nDirs As Long, nFiles As Long, lSize As Currency
   Dim sDir As String, sSrchString As String
   ListBox1.Clear
   sDir = "c:\test\"
   sSrchString = TextBox1
   'MousePointer = vbHourglass
   Label1.Caption = "Searching " & vbCrLf & UCase(sDir) & "..."
   lSize = FindFile(sDir, sSrchString, nDirs, nFiles)
   'MousePointer = vbDefault
   MsgBox Str(nFiles) & " " & " Dateien mit dem Namen " & sSrchString & " gefunden In" & Str(nDirs) & _
          " Verzeichnis", vbInformation
   'MsgBox "Total Size = " & lSize & " bytes"
End Sub
 
Private Function FindFile(ByVal sFol As String, sFile As String, _
   nDirs As Long, nFiles As Long) As Currency
   Dim tFld As Folder, tFil As File, FileName As String
   
   On Error GoTo Catch
   Set fld = fso.GetFolder(sFol)
   FileName = dir(fso.BuildPath(fld.path, sFile), vbNormal Or _
                  vbHidden Or vbSystem Or vbReadOnly)
   While Len(FileName) <> 0
      FindFile = FindFile + FileLen(fso.BuildPath(fld.path, _
      FileName))
      nFiles = nFiles + 1
      ListBox1.AddItem fso.BuildPath(fld.path, dir)  ' Load ListBox
      FileName = dir()  ' Get Next file
      DoEvents
   Wend
   Label1 = "Searching " & vbCrLf & fld.path & "..."
   nDirs = nDirs + 1
   If fld.SubFolders.Count > 0 Then
      For Each tFld In fld.SubFolders
         DoEvents
         FindFile = FindFile + FindFile(tFld.path, sFile, nDirs, nFiles)
      Next
   End If
   Exit Function
Catch:  FileName = ""
       Resume Next
End Function
 
Private Sub CommandButton2_Click()
Unload frmOrdnerSuchen
End Sub
 
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Dim dir As String
        dir = ListBox1
        Shell "explorer.exe " & dir, vbNormalFocus
 
End Sub
 
Private Sub UserForm_Click()
 
End Sub

Option Explicit
 
'Dieses Modul kann um nach Files / directorys auf Laufwerken Ordnern inclusive
'Unterordnern zu suchen In Projekte eingebunden werden.
'Es werden zwei Arrays ausgegeben
 'strFilesField$()          'Array enthält alle gefundenen File
 'lngFileAttributes&() 'Aarray enthält die zu den File gehörenden Atribute
'
'  r.mueller@sz-online.de
'
'läuft auch unter VBA
'
'In der Do Loop Schleife   K E I N   DoEvent einfügen!
' (Ärger wen du mehrmals auf das Start Button kommst)
 
Public Declare Function GetLogicalDrives _
       Lib "kernel32" () As Long
 
Public Declare Function GetDriveType _
       Lib "kernel32" Alias "GetDriveTypeA" _
       (ByVal lpRootPathName As String) As Integer
 
Public Declare Function GetLogicalDriveStrings _
       Lib "kernel32" Alias "GetLogicalDriveStringsA" _
      (ByVal nBufferLength As Long, _
       ByVal lpBuffer As String) As Long
       
       
Public Declare Function FindFirstFile Lib "kernel32" _
        Alias "FindFirstFileA" (ByVal lpFileName As String, _
        lpFindFileData As WIN32_FIND_DATA) As Long
        
Public Declare Function FindNextFile Lib "kernel32" _
        Alias "FindNextFileA" (ByVal hFindFile As Long, _
        lpFindFileData As WIN32_FIND_DATA) As Long
        
Public Declare Function FindClose Lib "kernel32" (ByVal _
        hFindFile As Long) As Long
 
Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type
 
Const MAX_PATH = 259
 
Type WIN32_FIND_DATA
  dwFileAttributes As Long
  ftCreationTime As FILETIME
  ftLastAccessTime As FILETIME
  ftLastWriteTime As FILETIME
  nxFilesizeHigh As Long
  nxFilesizeLow 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
 
Sub GetAllFiles(ByVal Root$, ByVal strPath$, ByRef strFilesField$(), ByRef lngFileAttributes&(), ByVal strSearchFile$, ByVal strInstanz&)
 'Findet alle (auch Hidden und System) strSearchFile$ im angegebenen Root
  'Procedur wird Recursiv aufgerufen
 Dim File$, hFile&, FD As WIN32_FIND_DATA
 Dim SFile$, ShFile&, SFD As WIN32_FIND_DATA
 Dim xAttrib&
 Dim SRoot$
 strInstanz = strInstanz + 1
 If Right(Root, 1) <> "\" Then Root = Root & "\"
  
 If strInstanz = 1 Then
  SRoot = Root
   ShFile = FindFirstFile(SRoot & strSearchFile$, SFD)
   If ShFile > 0 Then
    Do
     SFile = Left(SFD.cFileName, InStr(SFD.cFileName, Chr(0)) - 1)
     If Not (SFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
       If (SFile <> ".") And (SFile <> "..") Then
        strFilesField(UBound(strFilesField)) = SRoot & SFile
        lngFileAttributes(UBound(strFilesField)) = SFD.dwFileAttributes
        ReDim Preserve strFilesField(0 To UBound(strFilesField) + 1)
        ReDim Preserve lngFileAttributes&(0 To UBound(strFilesField))
       End If
     End If
    Loop While FindNextFile(ShFile, SFD)
  End If
 End If
   
 hFile = FindFirstFile(Root & strPath, FD)
 If hFile = 0 Then Exit Sub
 Do
  File = Left(FD.cFileName, InStr(FD.cFileName, Chr(0)) - 1)
  xAttrib& = FD.dwFileAttributes
  If (FD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
   If (File <> ".") And (File <> "..") Then
    SFile = File
    SRoot = Root
    GetAllFiles Root & File, strPath, strFilesField, lngFileAttributes, strSearchFile$, (strInstanz)
    If Right(SFile, 1) <> "\" Then SFile = SFile & "\"
    SRoot = SRoot & SFile
    ShFile = FindFirstFile(SRoot & strSearchFile$, SFD)
    If ShFile > 0 Then
     Do
      SFile = Left(SFD.cFileName, InStr(SFD.cFileName, Chr(0)) - 1)
      If Not (SFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
       If (SFile <> ".") And (SFile <> "..") Then
        strFilesField(UBound(strFilesField)) = SRoot & SFile
        lngFileAttributes(UBound(strFilesField)) = SFD.dwFileAttributes
        ReDim Preserve strFilesField(0 To UBound(strFilesField) + 1)
        ReDim Preserve lngFileAttributes&(0 To UBound(strFilesField))
       End If
      End If
     Loop While FindNextFile(ShFile, SFD)
    End If
   End If
   Call FindClose(ShFile)
  End If
 Loop While FindNextFile(hFile, FD)
 Call FindClose(hFile)
 
End Sub
 
Sub GetAllDirctory(ByVal Root$, ByVal strPath$, ByRef Field$(), ByRef lngFileAttributes&(), ByVal strSearchFile$, ByVal strInstanz&)
 'Findet alle (auch Hidden und System) strSearchFile$ im angegebenen Root
 'Procedur wird Recursiv aufgerufen
 Dim File$, hFile&, FD As WIN32_FIND_DATA
 Dim SFile$, ShFile&, SFD As WIN32_FIND_DATA
 Dim xAttrib&
 Dim SRoot$
 strInstanz = strInstanz + 1
 If Right(Root, 1) <> "\" Then Root = Root & "\"
  
 If strInstanz = 1 Then
  SRoot = Root
   ShFile = FindFirstFile(SRoot & strSearchFile$, SFD)
   If ShFile > 0 Then
    Do
     SFile = Left(SFD.cFileName, InStr(SFD.cFileName, Chr(0)) - 1)
     If (SFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
      If (SFile <> ".") And (SFile <> "..") Then
       Field(UBound(Field)) = SRoot & SFile
       lngFileAttributes(UBound(Field)) = SFD.dwFileAttributes
       ReDim Preserve Field(0 To UBound(Field) + 1)
       ReDim Preserve lngFileAttributes&(0 To UBound(Field))
      End If
     End If
    Loop While FindNextFile(ShFile, SFD)
  End If
 End If
   
 hFile = FindFirstFile(Root & strPath, FD)
 If hFile = 0 Then Exit Sub
 Do
  File = Left(FD.cFileName, InStr(FD.cFileName, Chr(0)) - 1)
  xAttrib& = FD.dwFileAttributes
  If (FD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
   If (File <> ".") And (File <> "..") Then
    SFile = File
    SRoot = Root
    GetAllDirctory Root & File, strPath, Field, lngFileAttributes, strSearchFile$, (strInstanz)
    If Right(SFile, 1) <> "\" Then SFile = SFile & "\"
    SRoot = SRoot & SFile
    ShFile = FindFirstFile(SRoot & strSearchFile$, SFD)
    If ShFile > 0 Then
     Do
      SFile = Left(SFD.cFileName, InStr(SFD.cFileName, Chr(0)) - 1)
      If (SFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
       If (SFile <> ".") And (SFile <> "..") Then
        Field(UBound(Field)) = SRoot & SFile
        lngFileAttributes(UBound(Field)) = SFD.dwFileAttributes
        ReDim Preserve Field(0 To UBound(Field) + 1)
        ReDim Preserve lngFileAttributes&(0 To UBound(Field))
       End If
      End If
     Loop While FindNextFile(ShFile, SFD)
    End If
   End If
   Call FindClose(ShFile)
  End If
 Loop While FindNextFile(hFile, FD)
 Call FindClose(hFile)
 
End Sub
 
Function AllDrives() As String
 'Funktion kann eingesetzt werden um alle Laufwerke zu ermitteln
 Dim strAllDrives$ 'enthält alle Laufwerke
 Dim xBitMask&
 Dim xi&
 xBitMask& = GetLogicalDrives()
 For xi& = 1 To 30
  If xBitMask& Mod 2 ^ xi& Then
   xBitMask& = xBitMask& - xBitMask& Mod 2 ^ xi&
   AllDrives$ = AllDrives + Chr$(xi& + 64)
  End If
 Next
End Function
 
Sub AlleLaufwerke(strAllDrivesName$(), lngAllDrivesTypNr&())
 'AlleLaufwerke mit Namen und deren Typ ermitteln
 Dim strAllDrives$
 Dim xDrivesCount&
 Dim xi&
 Dim xTxt$
 Dim lpRootPathName$
 Dim xTyp$
 
 ReDim xDrives(0) As String
 ReDim xDriveType(0) As Integer
 strAllDrives = Space$(128)
  Call GetLogicalDriveStrings(Len(strAllDrives), strAllDrives)
   strAllDrives = Trim$(strAllDrives)
  xDrivesCount& = Len(strAllDrives) \ 4
  ReDim strAllDrivesName$(1 To xDrivesCount&)
  ReDim lngAllDrivesTypNr&(1 To xDrivesCount&)
 For xi& = 1 To xDrivesCount&
  strAllDrivesName$(xi&) = Mid$(strAllDrives, (xi& - 1) * 4 + 1, 1)
  lpRootPathName$ = Mid$(strAllDrives, (xi& - 1) * 4 + 1, 4)
  lngAllDrivesTypNr&(xi&) = GetDriveType(lpRootPathName$)
 Next
End Sub
 
Sub LWsAnzeigen(strAllDrivesName$(), lngAllDrivesTypNr&())
 'Nur als Demo
 Dim xi&
 Dim xTxt$
 For xi& = 1 To UBound(strAllDrivesName$())
  xTxt$ = xTxt$ & strAllDrivesName(xi&) & " " & DriveTypName$(lngAllDrivesTypNr&(xi&)) & Chr$(13)
 Next
 MsgBox xTxt$
End Sub
Function DriveTypName$(lngDriveTypNr&)
  Select Case lngDriveTypNr
   Case 0
    DriveTypName$ = "Unbekannt"
   Case 1
    DriveTypName$ = "Kein Wurzelverzeichnis"
   Case 2
    DriveTypName$ = "Auswechselbar"
   Case 3
    DriveTypName$ = "Festplatte"
   Case 4
    DriveTypName$ = "Netzlaufwerk"
   Case 5
    DriveTypName$ = "CD-Rom"
   Case 6
    DriveTypName$ = "RAM-Disk"
  End Select
 
End Function

'An Beliebiger Stelle In deinem Project
Sub Beispiel()
Dim xi As Long
Dim strRoot As String
Dim strFilePlatzhalter As String
Dim lngInstanz As Long  'zählt die instanz der Recursiven Aufrufe. Keinen Wert übergeben!!!
Dim strSearchFile As String
 
ReDim lngFileAttributes(0) As Long 'array enthält die zu den Files gehörenden Atribute
ReDim strFiles(0) As String          'array enthält alle gefundenen File
strFilePlatzhalter = "*.*" 'darf nicht verändert werden!!! sonst werden nicht alle gefunden
 
strRoot = "D:\test\"  'Dein vorgegebener Pfad Beispiel
      'hier muß mindestens das Laufwerk stehen zb: C:\ .
      'im Modul: FileSearchDirectorySearch findest du Code um ggf alle LW zu ermitteln
 
strSearchFile = "test*.xls" ' oder auch: "*.Do*"   ''Hier kannst du den gesuchten Filenamen
                              'mit oder ohne Joker eintragen
 
Call GetAllxFiles(strRoot, strFilePlatzhalter, strFiles, lngFileAttributes, strSearchFile, (lngInstanz))
 
 'Demo Zur Ausgabe der gefundene File
For xi = LBound(strFiles) To UBound(strFiles) - 1
 MsgBox xi + 1 & vbCr & vbCr & strFiles(xi), , "Demo! Files gefunden: " & UBound(strFiles)
Next
End Sub