🚀 go-pugleaf

Dosyć podobne rozwiązanie:

'w znacznej części na podstawie:
'http://www.datastrat.com/Download/Picture2K.zip
'http://msdn.microsoft.com/en-us/library/dk008ty4.aspx
'Dir Function

Private Sub ReadFolderInfo(listaPlikow As String, _
                           strFolder As String, _
                           subfold As Boolean, _
                           strExt As String, _
                           nLevels As Long, _
                           Optional ByVal nLevel As Long)

Dim arrFolders() As String
ReDim arrFolders(19) As String 'do 20 podkatalogów na początek
Dim strRelFolder As String
Dim strFile As String
Dim nLen As Long 'żeby dwa razy nie obliczać długości folderu
Dim iLoop As Long, iLoop2 As Long

strFile = Dir(strFolder, vbDirectory)
iLoop = -1

While strFile <> ""

    'wykluczenie "/.." zapobiega wchodzeniu na wyższy folder, "/." do
siebie samego
    'maksymalna długość ścieżki to 260 (259 + Null), ale zdarzają się
pliki dłuższe
    If strFile <> "." And strFile <> ".." And strFile <> "" And
Len(strFolder & strFile) < 260 Then
        'Display the names in E:\ that represent directories.
        'Use bitwise comparison to make sure strFile is a directory.
            On Error Resume Next
        If (GetAttr(strFolder & strFile) And vbDirectory) =
vbDirectory Then
            'dzięki Resume Next można by pominąć warunek And
Len(strFolder & strFile) < 260
            If Err > 0 Then
                Err.Clear
                On Error GoTo 0 'też --> Err = 0 jak po Err.Clear
                GoTo nastepny_plik
            End If
            On Error GoTo 0

            iLoop = iLoop + 1
            If iLoop > UBound(arrFolders) Then ReDim Preserve
arrFolders(iLoop)
            arrFolders(iLoop) = strFile 'podkatalog do sprawdzenia w
kolejnym ReadFolderInfo

        'pliki inne niż katalogi
        Else
            On Error GoTo 0
            If InStr(Right(strFile, Len(strExt)), strExt) > 0 Then _
                    listaPlikow = listaPlikow & vbNewLine & strFolder
& strFile
        End If
    End If '., ..

nastepny_plik:
    strFile = Dir() ' Get next entry

Wend 'Loop

If subfold Then
    'arrFolders() - podkatalogi zapisane w kolejnych
    'If (GetAttr( ... powyższej pętli While
    nLevel = nLevel + 1
    'Debug.Print nLevel & "  " & nLevels
    If nLevels <> -1 And nLevel > nLevels Then Exit Sub
    For iLoop2 = 0 To iLoop
        ReadFolderInfo listaPlikow, strFolder & arrFolders(iLoop2) &
"\", subfold, strExt, nLevels, nLevel
    Next iLoop2
End If

End Sub

Sub wypisz_nazwy()

Dim listaPlikow As String

'katalog musi być ze slashem "\" na końcu
Call ReadFolderInfo(listaPlikow, "E:\Documents and Settings
\Administrator\My Documents\Bazy danych\", True, "txt", -1)
'True czyli z podkatalogami
'-1 czyli wszystkie poziomy w dół
'wyświtela same nazwy po zamianie
'listaPlikow = listaPlikow & vbNewLine & strFolder & strFile
'na
'listaPlikow = listaPlikow & vbNewLine & strFile

Debug.Print listaPlikow

End Sub