Directory Tree - Generates a list of subdirectories.

[Tech99]

Here is Bonney West last submitted version (List folders.zip post #13 in this thread) a bit optimized -> half second better performance per 10k path count.

Modifiation to the mnuBrowse_Click() subroutine (add three lines).

ListFolders sPath, "*." '<-- The "*." pattern fails to list folder names such as "New.Folder"
'ListFolders sPath, "*.*" '<--The "*.*" pattern is bit slower, but would find folder names such as New.Folder"

'Add these next three lines to the mnuBrowse_Click() subroutine
For i = LBound(dirNames) To UBound(dirNames)
    SendMessage m_hWndLB, LB_ADDSTRING, 0&, StrPtr(dirNames(i))
Next i

Replace whole ListFolders subroutine, with this code.

Private Sub ListFolders(ByRef FolderPath As String, Optional ByRef Pattern As String = "*")
'NOTE!!!                      FolderPath should not end in a trailing backslash (\)
Const ALLOC_CHUNK = 10&
Dim hFindFile As Long
Dim i As Long
Dim Length As Long
Dim SubFolder As String
Static lCount As Long

hFindFile = FindFirstFile(FolderPath & "\" & Pattern, m_WFD)

If hFindFile <> INVALID_HANDLE_VALUE Then
    Do        'Process folders only (junctions, symlinks & mounted folders won't be recursed)
        If (m_WFD.dwFileAttributes And (FILE_ATTRIBUTE_DIRECTORY Or FILE_ATTRIBUTE_REPARSE_POINT)) And Asc(m_WFD.cFileName) <> vbDot Then
            Length = lstrlen(m_WFD.cFileName)
            SubFolder = Left$(m_WFD.cFileName, Length)
            lCount = lCount + 1
            ReDim Preserve dirNames(lCount) As String
            dirNames(lCount) = FolderPath & ("\" & SubFolder & "\")
            ListFolders FolderPath & ("\" & SubFolder), Pattern 'Recurse subfolders
        End If
    Loop While FindNextFile(hFindFile, m_WFD)

    hFindFile = FindClose(hFindFile): Debug.Assert hFindFile
End If
End Sub

Add to module or form level.

Private Const vbDot = 46
Dim dirNames() As String