Dateisuche

Das Filesearchobject scheint nicht unter allen Umständen richtig zu funktionieren. Zumindestens unter XL97 und Windows 2000 kann es Probleme mit Wildcards (Zeichen, die einzelne ? oder beliebig viele Buchstaben ersetzen * ) geben. Mit Dir() kann man die Funktionen aber nachbauen. Leider lässt Dir() keine Rekursionen zu, deshalb muss erst das jeweile Verzeichnis komplett gelesen werden, dann kommen die Unterverzeichnisse dran.

Beispieldatei (filesearch.zip 18 KB)

'################################################
'# In das Klassenmodul von Tabelle1
'# Button cmbDateiliste, cmbNormalSearch, cmbSearchTree
'################################################

Private Sub cmbDateiliste_Click()
Dim a As New Collection, i As Long
With Worksheets("Tabelle1")
    .Range("A:A").ClearContents
    For i = 1 To MySearchList(.Range("E3"), .Range("E4"), a)
        .Cells(i, 1).Value = a(i)
    Next
End With
End Sub

Private Sub cmbNormalSearch_Click()
With Worksheets("Tabelle1")
    .Range("E11") = MySearch(.Range("E9"), .Range("E10"))
End With
End Sub

Private Sub cmbSearchTree_Click()
With Worksheets("Tabelle1")
    .Range("E17") = MySearch(.Range("E15"), .Range("E16"))
End With
End Sub

'###########################################
'# In ein Modul
'###########################################

Option Explicit

Private Declare Function SearchTreeForFile Lib "imagehlp" _
    (ByVal RootPath As String, ByVal InputPathName As String, _
    ByVal OutputPathBuffer As String) As Long
Private Const MAX_PATH = 260

Public Function FastDateiSearch(Datei As String, _
    Optional PfadBeginn As String)
Dim Buff As String
On Error Resume Next
If PfadBeginn = "" Then PfadBeginn = "c:\"
If Right(PfadBeginn, 1) <> "\" Then _
    PfadBeginn = PfadBeginn & "\"
Buff = String(MAX_PATH, 0)
SearchTreeForFile PfadBeginn, Datei, Buff
FastDateiSearch = Left(Buff, _
    InStr(1, Buff, Chr(0)) - 1)
End Function

Public Function MySearch(Datei As String, _
    PfadBeginn As String) As String
Dim directs As New Collection, Buff As String, a As Long
On Error Resume Next
If Right(PfadBeginn, 1) <> "\" Then _
    PfadBeginn = PfadBeginn & "\"
Buff = dir(PfadBeginn & Datei)
If Buff <> "" Then MySearch = PfadBeginn & Buff: Exit Function
Buff = dir(PfadBeginn & "*", vbDirectory)
Do While Buff <> ""
    If GetAttr(PfadBeginn & Buff) And vbDirectory Then
        If Buff <> "." And Buff <> ".." Then
            directs.Add PfadBeginn & Buff, Buff
        End If
    End If
    Buff = dir()
Loop
For a = 1 To directs.Count
    Buff = MySearch(Datei, directs(a))
    If Buff <> "" Then MySearch = Buff: Exit For
Next
End Function

Public Function MySearchList(Datei As String, _
    PfadBeginn As String, DirList As Collection) As Long
Dim directs As New Collection, Buff As String, a As Long
On Error Resume Next
If Right(PfadBeginn, 1) <> "\" Then _
    PfadBeginn = PfadBeginn & "\"
Buff = dir(PfadBeginn & Datei)
Do While Buff <> ""
    If Buff <> "" Then
        DirList.Add PfadBeginn & Buff, PfadBeginn & Buff
    End If
    Buff = dir()
Loop
Buff = dir(PfadBeginn & "*", vbDirectory)
Do While Buff <> ""
    If GetAttr(PfadBeginn & Buff) And vbDirectory Then
        If Buff <> "." And Buff <> ".." Then
            directs.Add PfadBeginn & Buff, Buff
        End If
    End If
    Buff = dir()
Loop
For a = 1 To directs.Count
    MySearchList Datei, directs(a), DirList
Next
MySearchList = DirList.Count
End Function