Startseite / Tipps / VB 5/6-Tipp 0414: Ordner mit Dir$ rekursiv durchsuchen

VB 5/6-Tipp 0414: Ordner mit Dir$ rekursiv durchsuchen

 von R. Mueller

'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 Modul "Module1" alias Module1.bas ---------


'Autor: R. Mueller
'E-Mail: r.mueller@sz-online.de

'Beitrag zum Thema Ordner und Laufwerke nach bestimmten oder
'allen Dateien rekursiv durchsuchen Beide dargestellten
'Varianten benutzen keine API sondern die Function Dir$

'1.Variante: Liste speichern in Datei
'2.Variante: Liste speichern Datenfeld

'Anmerkung: Die Ausgabe erfolgt zu Testzwecken sowohl im Debug-
'            Fenster als auch und in der Datei "C:\Test.txt"

Option Explicit

Public Sub Main()
    'Pfad durchsuchen
    Dim xpath As String
    
    'gesuchte Files keine Platzhalter
    Dim xSF As String
    Dim xfn As Long
    
    'Dateiname zum Speichern der Liste
    Dim xdn As String
    
    'Datenfeld zum Speichern der Liste
    ReDim xArray(0) As String
    
    'Array index
    Dim xln As Long
    Dim xi As Long
    
    'gesamtes Laufwerk durchsuchen
    'xpath = "D:"
    
    'Pfad durchsuchen z.B.
    'xpath = "D:\Eigene Dateien"
    
    xpath = Environ("USERPROFILE")
    
    'gesuchter Filename enthält folgenden String z.B.:
    'xSF = ".EXE" 'oder
    'xSF = ".v"   'oder
    'xSF = ".doc"
    
    xSF = ".htm"
    
    xSF = UCase(xSF)
    
    '1.Variante: Liste speichern in Datei
    xdn = "C:\Test.txt"  'Dateiname zum Speichern der Liste
    xfn = FreeFile
    Open xdn For Output As xfn
    Call xDirFile(xpath, xfn, xSF)
    Close xfn
    
    '2.Variante: Liste speichern Datenfeld
    Call xDirArray(xpath, xArray(), xln, xSF)
    
    'Ausgabe Array inhalt z.B.:
    For xi = 1 To UBound(xArray)
        Debug.Print xArray(xi)
    Next xi
End Sub

Public Sub xDirFile(xpath As String, xfn As Long, xSF As String)
    Dim xa As Long
    Dim xDir As String
    ReDim xt(0) As String
    Dim xi As Long
    Dim xAc As String
    
    xDir = Dir(xpath & "\*.*", vbNormal Or vbReadOnly Or vbHidden _
        Or vbSystem Or vbVolume Or vbDirectory Or vbArchive)
    
    xa = 0
    
    If Len(xDir) > 0 Then
        xt(0) = xDir
    End If
    
    Do While Len(xDir) > 0
        xDir = Dir
        If Len(xDir) > 0 And Not xDir = "." And Not xDir = ".." Then
            
            xa = xa + 1
            ReDim Preserve xt(xa)
            xt(xa) = xDir
        End If
    Loop
    
    For xi = 0 To xa
        If Len(xt(xi)) = 0 Then
            Exit For
        ElseIf Not xt(xi) = "." And Not xt(xi) = ".." Then
            If Len(Dir$(xpath & "\" & xt(xi), vbNormal Or vbReadOnly Or vbHidden _
                Or vbSystem Or vbVolume Or vbDirectory Or vbArchive)) > 0 Then
                
                If Not (GetAttr(xpath & "\" & xt(xi)) And vbDirectory) = vbDirectory Then
                    
                    If Len(xSF) > 0 Then
                        If InStr(1, UCase(xt(xi)), xSF) > 0 Then
                            xAc = xpath & "\" & xt(xi)
                            Print #xfn, xAc
                        End If
                    End If
                Else
                    Call xDirFile(xpath & "\" & xt(xi), xfn, xSF)
                End If
            End If
        End If
    Next xi
End Sub

Public Sub xDirArray(xpath As String, xArray() As String, xln As Long, xSF As String)
    Dim xa As Long
    Dim xDir As String
    ReDim xt(0) As String
    Dim xi As Long
    
    xDir = Dir$(xpath & "\*.*", vbNormal Or vbReadOnly Or vbHidden _
        Or vbSystem Or vbVolume Or vbDirectory Or vbArchive)
    
    '"\*.*" darf nicht verändert werden
    xa = 0
    
    If Len(xDir) > 0 Then
        xt(0) = xDir
    End If
    
    Do While Len(xDir) > 0
        xDir = Dir
        If Len(xDir) > 0 And Not xDir = "." And Not xDir = ".." Then
            
            xa = xa + 1
            ReDim Preserve xt(xa)
            xt(xa) = xDir
        End If
    Loop
    
    For xi = 0 To xa
        If Len(xt(xi)) = 0 Then
            Exit For
        ElseIf Not xt(xi) = "." And Not xt(xi) = ".." Then
            If Len(Dir(xpath & "\" & xt(xi), vbNormal Or vbReadOnly Or vbHidden _
                Or vbSystem Or vbVolume Or vbDirectory Or vbArchive)) > 0 Then
                
                'vbDirectory =16
                If Not (GetAttr(xpath & "\" & xt(xi)) And vbDirectory) = vbDirectory Then
                    
                    If Len(xSF) > 0 Then
                        If InStr(1, UCase(xt(xi)), xSF) > 0 Then
                            xln = xln + 1
                            ReDim Preserve xArray(xln)
                            xArray(xln) = xpath & "\" & xt(xi)
                        End If
                    End If
                Else
                    Call xDirArray(xpath & "\" & xt(xi), xArray(), xln, xSF)
                End If
            End If
        End If
    Next xi
End Sub
'---------- Ende Modul "Module1" alias Module1.bas ----------
'-------------- Ende Projektdatei Project1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 7 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.