VB 5/6-Tipp 0128: Dateien und Verzeichnisse rekursiv suchen

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Project1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Kontrollkästchen-Steuerelement "Check1"
' Steuerelement: Festplattenauswahlliste "Drive1"
' Steuerelement: Verzeichnisauswahlliste "Dir1"
' Steuerelement: Textfeld "Text2"
' Steuerelement: Textfeld "Text1"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Listen-Steuerelement "List1"
' Steuerelement: Beschriftungsfeld "Label6"
' Steuerelement: Beschriftungsfeld "Label5"
' Steuerelement: Beschriftungsfeld "Label4"
' Steuerelement: Beschriftungsfeld "Label3"
' Steuerelement: Beschriftungsfeld "Label2"
' Steuerelement: Beschriftungsfeld "Label1"


' Dank an Lothar Kriegerow für die Verwirklichung der Filter-
' funktion.

' Eine Warnung vorab!
' Die Dateien werden am Ende in einer Listbox angezeigt.
' Diese kann unter VB maximal 32768 Einträge anzeigen!
' Daher kommt es bei größeren Ordnern zu Fehlern.
' Diese liegen aber keineswegs an den API-Aufrufen.
' Um dies zu umgehen, sollten die Dateien anders angezeigt
' werden (in einem Listview zum Beispiel).

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 As Long = 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 As Long = &H20&
Const FILE_ATTRIBUTE_COMPRESSED As Long = &H800&
Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10&
Const FILE_ATTRIBUTE_HIDDEN As Long = &H2&
Const FILE_ATTRIBUTE_NORMAL As Long = &H80&
Const FILE_ATTRIBUTE_READONLY As Long = &H1&
Const FILE_ATTRIBUTE_SYSTEM As Long = &H4&
Const FILE_ATTRIBUTE_TEMPORARY As Long = &H100&

Private Sub Dir1_Change()
    Text1.Text = Dir1.Path
End Sub

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

Private Sub Form_Load()
    Text1.Text = Dir1.Path
    Text2.Text = "*.*"
End Sub

Private Sub Command1_Click()
    Dim Files() As String
    Dim X As Long
    Dim Such As String
    Dim DatCnt As Integer, DirCnt As Integer
    Dim Max As Long
    
    ' Ein Einfaches Suchmuster erstellen
    Such = Trim$(UCase$(Text2.Text))
    If Left$(Such, 1) = "*" Then Such = Right$(Such, Len(Such) - InStr(Such, "."))
    
    ReDim Files(0 To 0)
    
    ' Suchen
    MousePointer = 11
    DoEvents
    
    Max = GetAllFiles(LCase(Text1.Text), Such, Files, _
        (Check1.Value = Checked))
        
    MousePointer = 0
    DoEvents
    
    List1.Clear
    
    ' Die Ergebnisse auflisten
    List1.Visible = False
    For X = 0 To Max - 1
        List1.AddItem Files(X)
        
        If Left$(Files(X), 2) = ">>" Then
            DirCnt = DirCnt + 1
        Else
            DatCnt = DatCnt + 1
        End If
    Next X
    List1.Visible = True
    
    Label5.Caption = DirCnt
    Label6.Caption = DatCnt
End Sub

' Durchsucht einen Ordner nach Dateien
' Sollte der Ordner selbst nicht durchsucht werden können,
' gibt die Funktion 0 zurück. Sonst wird die Anzahl der Dateien zurückgegeben
Private Function GetAllFiles(ByVal Root As String, _
    ByVal Such As String, ByRef Field() As String, _
    Optional DoRecursion As Boolean = False, _
    Optional UsedField As Long = 0) As Long
    
    Dim File As String
    Dim hFile As Long
    Dim FD As WIN32_FIND_DATA
    
    ' Evtl. Array vergrößern?
    If (UsedField = UBound(Field)) Then
        ReDim Preserve Field(UBound(Field) + 100)
    End If
    
    DoEvents
    
    'Backslash ergänzen
    If Right(Root, 1) <> "\" Then Root = Root & "\"
    
    ' Die erste Datei suchen
    hFile = FindFirstFile(Root & "*.*", FD)
    
    ' Es konnte nichts gefunden werden
    If hFile = 0 Then
        GetAllFiles = 0
        Exit Function
    End If
    
    ' Für jede Datei
    Do
        ' Den Dateinamen extrahieren
        File = Left(FD.cFileName, InStr(FD.cFileName, Chr(0)) - 1)
        
        ' Ist die Datei ein Verzeichnis?
        If (FD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) _
            = FILE_ATTRIBUTE_DIRECTORY Then
            
            ' . und .. ignorieren
            If (File <> ".") And (File <> "..") Then
            
                ' Unterordner auch durchsuchen?
                If DoRecursion Then
                    
                    ' Unterordner rekursiv erfassen
                    GetAllFiles = GetAllFiles + GetAllFiles(Root & File, _
                        Such, Field, DoRecursion, UsedField)
                Else
                    
                    ' Ergebnis speichern
                    ' Verzeichnis: ">>" kann entfernt werden,
                    ' da nur zur Visualisierung
                    Field(UsedField) = ">>" & Root & File
                    GetAllFiles = GetAllFiles + 1
                    UsedField = UsedField + 1
                    
                    ' Evtl. Array vergrößern
                    If (UsedField = UBound(Field)) = 0 Then
                        ReDim Preserve Field(0 To UBound(Field) + 100)
                    End If
                End If
            End If
        Else
            
            ' Passt das Suchmuster?
            If (Such Like Right$(UCase$(File), Len(Such))) Or Such = "*" Then
                
                ' Ergebnis speichern
                ' Datei: "    " kann entfernt werden,
                ' da nur zur Visualisierung
                Field(UsedField) = "    " & Root & File
                GetAllFiles = GetAllFiles + 1
                UsedField = UsedField + 1
                
                ' Evtl. Array vergrößern
                If (UsedField = UBound(Field)) Then
                    ReDim Preserve Field(0 To UBound(Field) + 100)
                End If
            End If
        End If
    
    ' Nächste Datei suchen
    Loop While FindNextFile(hFile, FD)
    
    ' Suchhandle wieder freigeben - Suche beenden
    Call FindClose(hFile)
End Function
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Project1.vbp --------------

Kommentar von Ulli am 07.11.2006 um 14:52

Die Dateinamen sind alle absolut, also C:\Ordner\Datei.txt

mfg Ulli

Kommentar von condor am 06.11.2006 um 09:10

sind die dateinamen in "Files(X)" absolut (zb. c:\verz\datei.txt) oder relativ (zb. datei.txt)?

Kommentar von U.Gnewuch am 05.11.2006 um 12:36

Hi,

ich würde gerne nach dem Suchen der Dateien diese dann auch öffen. Allerdings taucht dann immer der "Fehler 52: Dateiname oder -nummer falsch" auf.

For X = 0 To Max - 1
        Open Files(X) For Input As #1
           Do While Not EOF(1)
               Line Input #1, sZeile
               sDateiinhalt = sDateiinhalt & sZeile
                Loop
            Close #1
            AlleDateien = AlleDateien & Format & _ sDateiinhalt
Next X

mfg Ulli

Kommentar von Alfred Hellmüller am 22.03.2004 um 14:41

Tip 128: In GetAllFiles erfolgt bei jedem gefundenen Objekt (Dir oder File) ein Redim Preserve. Dies ist äusserst ineffizient, da Redim Preserve stets ein Umkopieren des Arrays bewirkt. Empfehlung: Einführen eines Counters in der Do-Schleife; Increment bei jedem gefundenen und zu speichernden Objekt. Redim Preserve nur bei jedem - sagen wir 50ten Durchgang. Also:

'Store
Cntr = Cntr + 1
Field(Cntr) = " " & Root & File
If Cntr mod 50 = 0 then ReDim Preserve Field (UBound(Field) + 50)

Um exakt zu sein, soll am Schluss Redim Preserve Field(Cntr) erfolgen; ist aber nicht zwingend notwendig (einige leere Felder).
Mit diesem Ansatz wird der Search im LICHTJAHRE schneller.

Gruss
Alfred Hellmüller

Kommentar von condor am 14.08.2003 um 23:20

mein senf dazu... (des is imho universeller einsetzbar)

Public Function DirFiles(Wo As String, Maske As String, Rek As Boolean, ByRef FilesArray() As String, ByRef DirsArray() As String) As Boolean

Dim name1, pfad1
Dim WFD As WIN32_FIND_DATA, hSearch As Long, Cont As Integer
'Dim DoWeScan As Boolean
Dim FilesCount As Long, DirsCount As Long, i As Long
ReDim FilesArray(15&)
ReDim DirsArray(15&)

'DoWeScan = True
DirFiles = True
Maske = LCase(Maske)
i = -1
FilesCount = -1
DirsCount = -1
name1 = vbNullString
pfad1 = Wo

If Right(pfad1, 1) = "\" Then pfad1 = Left(pfad1, Len(pfad1) - 1)
GoSub AddDir 'list2.AddItem pfad1

Do 
    i = i + 1
    pfad1 = DirsArray(i)
        
        hSearch = FindFirstFile(pfad1 & "*", WFD)
        If hSearch <> INVALID_HANDLE_VALUE Then
            Cont = 1
            Do While Cont 'And DoWeScan
                name1 = TrimNull(WFD.cFileName)
                If name1 <> "." And name1 <> ".." Then
                    If GetFileAttributes(pfad1 & name1) And FILE_ATTRIBUTE_DIRECTORY Then
                        If Rek Then GoSub AddDir 
                    ElseIf LCase(name1) Like Maske Then
                        GoSub AddFile
                    End If
                End If
                Cont = FindNextFile(hSearch, WFD)   
            Loop
        End If
        Cont = FindClose(hSearch)
Loop While DirsCount > i

ReDim Preserve DirsArray(DirsCount)
If FilesCount > -1 Then
    ReDim Preserve FilesArray(FilesCount)
Else
    ReDim FilesArray(VbZero)
    DirFiles = False '-- falls keine datein gefunden wurden
End If

Exit Function
AddDir:
    DirsCount = DirsCount + 1
    If UBound(DirsArray) <= DirsCount Then ReDim Preserve DirsArray(UBound(DirsArray) * 2)
    DirsArray(DirsCount) = pfad1 & name1 & "\"
    'Debug.Print pfad1 & name1 & "\"
Return
AddFile:
    FilesCount = FilesCount + 1
    If UBound(FilesArray) <= FilesCount Then ReDim Preserve FilesArray(UBound(FilesArray) * 2)
    FilesArray(FilesCount) = pfad1 & name1
    'Debug.Print pfad1 & name1
Return
End Function
Public Function TrimNull(s As String) As String
Static i As Long
i = InStr(s, vbNullChar)
If i > 0 Then
    TrimNull = Left(s, i - 1)
Else
    TrimNull = s
End If
End Function

wenn DoWeScan eine globale variable ist und plötzlich auf false gesetzt wird, kann früher abgebrochen werden.
btw, like-operator erlaubt ausserdem 'reguläre ausdrücke'.
...ich hab derweil auch nix flotteres als meine DirFiles-Function (rennt ab vb4/win95 :)

Kommentar von Master-of-Desaster am 11.05.2003 um 19:21

der tipp is echt supper....
zu so einem ergebnus kommt man sonst nur mit viel viel arbeit

Kommentar von Max Riester am 04.04.2003 um 09:12

Die kompakteste und beste Lösung, die ich zu diesem Thema fand.
Wo findet man eine ordentliche Dokumentation um selbst mit diesen API
funktionen arbeiten zu können?

Kommentar von stephan am 04.02.2003 um 11:24

Funktioniert nicht!
Index ausserhalb des gültigen Bereichs ist die Fehlermeldung.
so'n Quatsch!

Kommentar von fat am 21.01.2003 um 16:32

und noch wasm wenn ich große ordner oder ordner mit sauvielen dateien durchforste, "Überlauf" die zeile

DatCnt = DatCnt + 1

wird als fehlerhaft angegeben ;/

Kommentar von fat am 21.01.2003 um 16:30

wie kann ich mit diesem projekt nun die größe aller dateien in der listbox anzeigen lassen????

Kommentar von Eckard Ahlers am 08.01.2003 um 20:56

Habs gegen die Dateisuche mit dem Scripting.FileSystemObject getestet. APIs sind ca. 100 mal schneller, aber leider nicht annähernd so elegant.

Der Suchpfad hat nur komische Sachen gemacht, bis ich die Abfrage
'If Such$ = Right$(UCase$(File), Len(Such$)) Or Such$ = "*" Then'
mit
'If (UCase(File) Like Such$) Then'
ersetzt habe.

Kommentar von S-A-M-M am 04.07.2002 um 09:53

Findet nicht alle Dateien (wie das die Explorersuche tut)

Kommentar von moLTe am 17.04.2002 um 17:32

32768 weil der Index der ListBox nur mit Integer deklariert wurde musst halt den ListView nehmen.

Kommentar von Moi am 14.04.2002 um 00:28

32000 Files und das Prog schmiert ab.

Kommentar von gehtdichnixan am 02.04.2002 um 09:02

Stürtzt ständig mit Speicherfehler ab, irgendwie scheisse.

Kommentar von Peter A. Landau am 29.03.2002 um 16:21

"In VB gibt es keine eigenen Funktionen die auf einfache Art und Weise rekursives Suchen in Verzeichnisstrukturen ermöglichen."
Doch, über Scripting.FileSystemObject.

Kommentar von Oliver Hausler am 18.11.2001 um 13:23

Lasst euch mal sagen, dass das ganze Thema ein einziges Trauerspiel ist. Ist der Code eigentlich in VB geschrieben oder in Assembler ;-) Sorry, ich musste das loswerden.

Kommentar von Bodo Wiswe am 23.08.2001 um 14:37

Ich finde es einfach Klasse, dass sich jemand die Mühe macht sowas zu veröffentlichen, und bedanke mich hiermit bei Autor.ICH LIEBE ACTIVE VB, hier findet man ALLES!:-)

Kommentar von JoWi am 16.08.2001 um 09:23

Also der Tipp ist wirklich super! Trotzdem verstehe ich es noch immer nicht, wie ich die Dateigröße und das Zeitformat in das bekannte Format des Explorers umwandeln kann! Kann mir jemand helfen?
Danke im Vorraus
Jochen

Kommentar von Martin Preinesberger am 08.06.2001 um 05:50

Bei der Suchmaske *.* werde auch Unterverzeichnisse durchsucht. Bei der Suchmaske "Kopie von*" geht es aber nicht.
Hat jemand da ne lösung?
MfG Merlin

Kommentar von LotharK am 14.04.2001 um 11:29

Das Problem, bestimmte Dateien rekursiv zu suchen habe ich ganz einfach durch folgende Zeile gelöst:
If Right$(UCase$(File), Len(Patt$)) = UCase$(Patt$) Then
Natürlich muß Der Suchstring in der Zeile
hFile = FindFirstFile(Root & "*.*", FD)
dabei immer auf *.* gesetzt sein.

Kommentar von Daniel Pramel am 09.04.2001 um 12:16

Wieso macht man es nicht einfach so:
Erst nach *.* suchen lassen und vor dem Hinzufügen des Eintrages durch z.B.:
if right(strDatei,3)=strEndung
überprüfen, ob es der gewünschte Dateityp ist.
Ist ein bißchen zusammengeschustert, aber es funktioniert. Und die performance ist
auch okay. *g*

Kommentar von Dieter Langens am 04.04.2001 um 09:44

Wenn ich als Suchmuster z.B. *.jpg eingebe, dann stürzt VB mit einer Zugriffsverletzung gnadenlos ab. Beim Suchmuster *.* funktioniert es einwandfrei. Woran könnte das denn liegen ?

Kommentar von Major am 06.02.2001 um 10:58

wie kann das prog. auch untergeordnete ordner durch suchen ?

Kommentar von Götz Reinecke am 17.10.2000 um 19:19

mhmja, das ist ein Problem, da VB keine Vorzeichenlose Longs kennt.
Eine Idee wäre, den Long nach Rückgabe an eine Fließkommazahl zu übergeben und dann daraus das Zweierkomplement zu bilden.
Ich meine mich zu entsinnen, daß Du dafür das Bitmuster invertieren und das Ergebnis um eins erhöhen mußt.

Kommentar von Gerhard Hölbling am 17.10.2000 um 17:36

Die Dateigröße ist alls Long definiert.
Wenn ich z.B. eine Datei mit 4 GB habe wird mir alls Dateigröße ein Minus Wert zurückgegeben. Wie kann ich das umgehen und die richtige Dateigröße erfragen