Private Sub Pfade(OrdnerPfad As String)
On Error Resume Next
Dim d() As String, i As Integer, DirName As String, Anzahl As Integer
Dim pos As Integer, Pfad As String, z As Integer, weiter As Boolean
On Error Resume Next
OrdnerPfad = OrdnerPfad + "\"
pos = 1
weiter = False
z = 0
With Dir1
    .Path = OrdnerPfad
    DirName = Dir(OrdnerPfad + DatTyp)
    Pfad = OrdnerPfad + DirName
    Do Until DirName = ""
        Pfad = OrdnerPfad + DirName
        pos = InStr(pos + z, Pfad, "-")
        If pos > 0 Then
 
        If IsNumeric(Mid$(Pfad, pos - 1, 1)) And _
         IsNumeric(Mid$(Pfad, pos + 1, 1)) And _
         IsNumeric(Mid$(Pfad, pos + 4, 1)) And _
         (Mid$(Pfad, pos - 3, 1) = " " Or Mid$(Pfad, pos - 3, 1) = "\") And _
         Mid$(Pfad, pos + 3, 1) = "-" Then
 
            For z = 1 To Len(Pfad)
                If Mid$(Pfad, z + pos, 1) = "\" Then
                    weiter = True
                    Exit For
                End If
                If Mid$(Pfad, z + pos, 1) = "." Then
                    weiter = False
                    pos = 1
                    z = 0
                    Exit For
                End If
            Next z
            If weiter = True Then
                lstGefunden.AddItem Left(Pfad, pos + z - 1)
            Else
                lstGefunden.AddItem Pfad
 
            End If
        End If
        End If
        If weiter = False Then DirName = Dir
    Loop
 
    DoEvents
    Anzahl = .ListCount
    ReDim d(Anzahl)
 
    For i = 1 To Anzahl
        d(i) = .List(i - 1)
        If (i Mod 4) = 0 Then
            Label1.Caption = d(i)
        End If
    Next i
 
    For i = 1 To Anzahl
        Call Pfade(d(i))
    Next i
 
End With
End Sub