Форум программистов [Powered by Invision Power Board]

Код

' ==============================================
' Class CFolderProcessor
' codded by JUmPER
' ==============================================
Option Explicit

Private fso As New FileSystemObject
Private folders() As String
'

' конструктор класса
Public Sub init(Optional aRootPath As String = "")
    If (aRootPath = "") Then ' добавление всех папок со всех дисков (по умолчанию)
        Dim oDrives As Drives
        Dim cur_drive As Drive

        Set oDrives = fso.Drives
        For Each cur_drive In oDrives
            Call merge(folders, GetFolders(cur_drive.Path & "\"))
        Next
    Else ' добавление папок только внутри корневой
        folders = GetFolders(aRootPath)
    End If

    Randomize
End Sub

' случайная папка ;)
Public Function GetRandomFolder() As String
    Dim indx As Long

    indx = Round(rnd() * UBound(folders))

    GetRandomFolder = folders(indx)
End Function

' рекурсивная функция получения подпапок текущей папки (текущая тоже включается в результат)
Private Function GetFolders(aFolderPath As String) As String()
    Dim oFolder As folder
    Dim oFolders As folders
    Dim result() As String
    Dim cur_folder As folder
    Dim i As Long

    ' получение подпапок
    On Error GoTo L_ACCESS_DENIED
    Set oFolder = fso.GetFolder(aFolderPath)
    Set oFolders = oFolder.SubFolders
    ReDim result(oFolders.Count)
    On Error GoTo 0

    ' добавление текущих поддиректорий
    result(0) = aFolderPath
    i = 1
    For Each cur_folder In oFolders
        result(i) = cur_folder.Path
        i = i + 1
    Next

    ' рекурсивное добавление детей детей и т.д.
    For Each cur_folder In oFolders
        Call merge(result, GetFolders(cur_folder.Path))
    Next

    GetFolders = result

    Exit Function
L_ACCESS_DENIED: ' доступ к директории закрыт.
    Dim res() As String ' возвращаем пустой массив
    GetFolders = res
End Function

' добавление второго массива в первый
Private Sub merge(ByRef arr1, ByRef arr2)
    Dim i As Long
    Dim arr1_len As Long
    Dim arr2_len As Long

    If (isEmptyArray(arr2)) Then
        Exit Sub
    End If

    If (isEmptyArray(arr1)) Then
        arr1 = arr2
        Exit Sub
    Else
        arr1_len = UBound(arr1) + 1
    End If

    arr2_len = UBound(arr2) + 1

    ReDim Preserve arr1(arr1_len + arr2_len - 1)
    For i = 0 To arr2_len - 1
        If (IsObject(arr2(i))) Then
            Set arr1(i + arr1_len) = arr2(i)
        Else
            arr1(i + arr1_len) = arr2(i)
        End If
    Next
End Sub

' проверка массива на пустоту (во избежание исключительной ситуации при обращении к пустому массиву)
Private Function isEmptyArray(ByRef aArr) As Boolean
    On Error GoTo invalid

    Dim a As Integer
    a = UBound(aArr)
    isEmptyArray = (a < 0)
    Exit Function

invalid:
    isEmptyArray = True
End Function