Developing.ru

Код: Выделить всё

Public FileNames As Collection

Sub Main()
    On Error Resume Next
    ' оставьте одну из следующих двух строк:
    ПутьКПапкеСФайлами = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "")    ' там же, где и этот файл
    ПутьКПапкеСФайлами = "D:\Проекты"    ' конкретная папка

    Set FileNames = New Collection: On Error Resume Next
    Call ReadFileNames(ПутьКПапкеСФайлами)    ' поиск подходящих файлов во всех подпапках

    For Each file In FileNames
        Debug.Print file
        ' ОбработкаФайла file
    Next
End Sub


Function ReadFileNames(ByVal FolderPath As String)
    Set fso = CreateObject("scripting.filesystemobject")
    Set curfold = fso.GetFolder(FolderPath)

    If Not curfold Is Nothing Then
        For Each fil In curfold.Files
            If fil.Path Like "*.xls*" Then FileNames.Add fil.Path
        Next
        For Each sfol In curfold.SubFolders
            ReadFileNames sfol.Path
        Next
        Set fil = Nothing: Set curfold = Nothing: Set fso = Nothing:
    End If
End Function

Код: Выделить всё

Option Explicit

Private Const MAX_PATH = 260

Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

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

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 Boolean
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Boolean

Private Sub WorkWithFile(SourceDir As String, FileName As String)
    ' Здесь работаем с файлами
End Sub

Private Sub RecursiveSubprogram(Source As String)
    Dim objName As String
    Dim hSearch As Long
    Dim WFD As WIN32_FIND_DATA
    Dim Cont As Boolean

    Cont = True
    hSearch = FindFirstFile(Source & "*", WFD)
    If hSearch <> INVALID_HANDLE_VALUE Then
        Do While Cont
            objName = Left(WFD.cFileName, InStr(WFD.cFileName, Chr(0)) - 1)
            If Not (objName = "." Or objName = "..") Then
                If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = 0 Then
                    Call WorkWithFile(Source, objName)
                Else
                    RecursiveSubprogram Source & objName & "\"
                End If
            End If
           Cont = FindNextFile(hSearch, WFD)
        Loop
        Cont = FindClose(hSearch)
    End If
End Sub

Function TestRecursiveEnumerate()
    'Отсюда начинаем рекурсию
    RecursiveSubprogram "C:\Folder1\"
End Function

Код: Выделить всё

Option Explicit

Sub Test()
    Call RecursiveEnumerator("C:\prog\vba\")
End Sub

Sub RecursiveEnumerator(MyPath As String)
    Dim MyName As String, SubDir() As String, i As Long
    
    ReDim SubDir(0 To 0) As String
    MyName = Dir(MyPath, vbDirectory)
    Do While MyName <> ""
        If MyName <> "." And MyName <> ".." Then
            If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
                i = UBound(SubDir) + 1
                ReDim Preserve SubDir(0 To i) As String
                SubDir(i) = MyPath & MyName & "\"
            Else
                Call FilePrecessing(MyPath, MyName)
            End If
        End If
        MyName = Dir
    Loop
    
    i = 1
    Do While i <= UBound(SubDir)
        Call RecursiveEnumerator(SubDir(i))
        i = i + 1
    Loop
End Sub

Sub FilePrecessing(Directory As String, FileName As String)
    Debug.Print Directory & FileName
End Sub