I became motivated to provide for myself with a kind of universal function which returns a collection of folder objects plus optionally all sub-folders all in ascending order. The collection then may be used for any purpose just by looping through the collection. The function looks as follows:
Public Function Folders(Optional ByVal fo_spec As String = vbNullString, _
Optional ByVal fo_subfolders As Boolean = False, _
Optional ByRef fo_result As String) As Collection
' ----------------------------------------------------------------------------
' Returns all folders in a folder (fo_spec) - optionally including all
' sub-folders (fo_subfolders = True) - as folder objects in ascending order.
' When no folder (fo_spec) is provided a folder selection dialog request one.
' When the provided folder does not exist or no folder is selected the
' the function returns with an empty collection. The provided or selected
' folder is returned (fo_result).
' ----------------------------------------------------------------------------
Static cll As Collection
Static Queue As Collection ' FiFo queue for folders with sub-folders
Static Stack As Collection ' LiFo stack for recursive calls
Static foStart As Folder
Dim aFolders() As Variant
Dim fl As File
Dim flStart As Folder
Dim fo1 As Folder
Dim fo2 As Folder
Dim fso As New FileSystemObject
Dim i As Long
Dim j As Long
Dim s As String
Dim v As Variant
If cll Is Nothing Then Set cll = New Collection
If Queue Is Nothing Then Set Queue = New Collection
If Stack Is Nothing Then Set Stack = New Collection
If Queue.Count = 0 Then
'~~ Provide the folder to start with - when not provided by fo_spec via a selection dialog
If fo_spec <> vbNullString Then
If Not fso.FolderExists(fo_spec) Then
fo_result = fo_spec
GoTo xt
End If
Set fo1 = fso.GetFolder(fo_spec)
Else
Application.DisplayAlerts = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select the desired folder!"
.InitialFileName = CurDir
.AllowMultiSelect = False
If .Show <> -1 Then GoTo xt
Set fo1 = fso.GetFolder(.SelectedItems(1))
End With
End If
Set foStart = fo1
Else
'~~ When recursively called (Queue.Count <> 0) take first sub-folder queued
Set fo1 = Queue(1)
End If
For Each fo2 In fo1.SubFolders
cll.Add fo2
If fo1.SubFolders.Count <> 0 And fo_subfolders Then
Queue.Add fo2
End If
Next fo2
Stack.Add cll ' stack result in preparation for the function being called resursively
If Queue.Count > 0 Then
Queue.Remove 1
End If
If Queue.Count > 0 Then
Folders Queue(1).Path ' recursive call for each folder with subfolders
End If
xt: Set fso = Nothing
If Stack.Count > 0 Then
Set cll = Stack(Stack.Count)
Stack.Remove Stack.Count
End If
If Stack.Count = 0 Then
If cll.Count > 0 Then
'~~ Unload cll to array, when fo_subfolders = False only those with a ParentFolder foStart
ReDim aFolders(cll.Count - 1)
For Each v In cll
aFolders(i) = v
i = i + 1
Next v
'~~ Sort array from A to Z
For i = LBound(aFolders) To UBound(aFolders)
For j = i + 1 To UBound(aFolders)
If UCase(aFolders(i)) > UCase(aFolders(j)) Then
s = aFolders(j)
aFolders(j) = aFolders(i)
aFolders(i) = s
End If
Next j
Next i
'~~ Transfer array as folder objects to collection
Set cll = New Collection
For i = LBound(aFolders) To UBound(aFolders)
Set fo1 = fso.GetFolder(aFolders(i))
cll.Add fo1
Next i
End If
Set Folders = cll
If Not foStart Is Nothing Then fo_result = foStart.Path
End If
Set cll = Nothing
End Function
The function had been tested as follows:
Private Sub Folders_Test()
Const TEST_FOLDER = "E:\Ablage\Excel VBA\DevAndTest"
Dim v As Variant
Dim cll As Collection
Dim s As String
Dim sStart As String
Set cll = Folders("c:\XXXX", True, sStart)
s = "1. Test: Folders in a provided non-existing folder ('" & sStart & "')"
Debug.Print vbLf & s
Debug.Print String(Len(s), "-")
Debug.Assert cll.Count = 0
Set cll = Folders(TEST_FOLDER, , sStart)
s = "2. Test: Folders in the provided folder '" & sStart & "' (without sub-folders):"
Debug.Print vbLf & s
Debug.Print String(Len(s), "-")
For Each v In cll
Debug.Print v.Path
Next v
Set cll = Folders(TEST_FOLDER, True, sStart)
s = "3. Test: Folders in the provided folder '" & sStart & "' (including sub-folders):"
Debug.Print vbLf & s
Debug.Print String(Len(s), "-")
For Each v In cll
Debug.Print v.Path
Next v
Set cll = Folders(, True, sStart)
s = "4. Test: Folders in the manually selected folder '" & sStart & "' (including sub-folders):"
Debug.Print vbLf & s
Debug.Print String(Len(s), "-")
For Each v In cll
Debug.Print v.Path
Next v
End Sub
