List folders without using FSO

I am trying to return an array of folder names without using FSO. Is there anyway Dir can be used to return folders only?

Below is code I am trying to alter to return folder names

Option Explicit

Public Function fnavarGet1dArrFiles_ByDir(ByVal strStartFolder As String, _
                                            Optional ByVal strFileFilter As String = "*", _
                                            Optional ByVal blnReturnFullName As Boolean _
                                            ) As Variant

'// Returns an array of file names that match strFileFilter
'// Use argument to choose whether you want FullNames or FileNames only
'// If no matching files are found, it returns Empty

'// Credits: adapted from function by John Walkenbach

'// Note: The strFileFilter is NOT case sensitive
'// Dir method does not detect hidden files

    Dim avarFileArray() As Variant
    Dim lngFileCount    As Long
    Dim strFileName     As String

    On Error GoTo ErrHandler

    strStartFolder = fnstrGetSeparatoredPath(strStartFolder)

    If Not fnblnExistsFileFolder(strStartFolder) Then
        GoTo NoFilesFound
    End If

    'If no files in folder, exit the sub
    strFileName = Dir(strStartFolder & strFileFilter)
    If Len(strFileName) = 0 Then
        GoTo NoFilesFound
    End If

    'Loop until no more matching files are found
    If blnReturnFullName Then
        Do While Len(strFileName)
            lngFileCount = lngFileCount + 1
            ReDim Preserve avarFileArray(1 To lngFileCount)
            avarFileArray(lngFileCount) = strStartFolder & strFileName
            strFileName = Dir()
        Loop
    Else
        Do While Len(strFileName)
            lngFileCount = lngFileCount + 1
            ReDim Preserve avarFileArray(1 To lngFileCount)
            avarFileArray(lngFileCount) = strFileName
            strFileName = Dir()
        Loop
    End If

    fnavarGet1dArrFiles_ByDir = avarFileArray
Exit Function

ErrHandler:
    fnavarGet1dArrFiles_ByDir = Empty
Exit Function

NoFilesFound:
    fnavarGet1dArrFiles_ByDir = Empty
End Function

Public Function fnblnExistsFileFolder(ByVal strFullName As String) As Boolean
'adapted from function written by Ken Puls (www.excelguru.ca)
    If Len(strFullName) Then
        On Error Resume Next
        fnblnExistsFileFolder = Len(Dir(strFullName, 31))
        On Error GoTo 0
    End If
End Function

Public Function fnstrGetSeparatoredPath(ByRef strPath As String, Optional ByVal blnInvert As Boolean) As String
'/ ensures folder path ends in path separator (aka trailing backslash)
'/ doesn't detect garbage input, requires a Path arg
    Dim blnChange As Boolean
    Const strcPATH_SEPARATOR As String = "\"

    If Len(strPath) Then
        blnChange = ((Right$(strPath, 1) = strcPATH_SEPARATOR) = blnInvert)
        If Not blnChange Then
            fnstrGetSeparatoredPath = strPath
        ElseIf Not blnInvert Then
            'add trailing separator
            fnstrGetSeparatoredPath = strPath & strcPATH_SEPARATOR
        Else
            'remove last character
            fnstrGetSeparatoredPath = Left$(strPath, Len(strPath) - 1)
        End If
    End If
End Function

You can And the attributes (via GetAttr) with vbDirectory to see if it's a file or folder.

Originally Posted by shg

You can And the attributes (via GetAttr) with vbDirectory to see if it's a file or folder.

Thanks shg. When I use get attributes and vbDirectory, it returns a few files in addition to the folders.

Try this.

Sub ListDirectories()
    Dim sDirName As String, sPath As String
    sPath = "C:\"
    sDirName = Dir(sPath, vbDirectory)
    Do Until Len(sDirName) = 0
        'only list folders
       If GetAttr(sPath & sDirName) And vbDirectory Then
            Debug.Print sDirName
        End If
        sDirName = Dir 'get next file
   Loop
End Sub

Thanks bakerman! (Reps) It works.


For anyone who found on this thread while searching for a solution, the finished code is below:

Public Function fnavarGet1dArrFolders_ByDir(ByVal strStartFolder As String, _
                                            Optional ByVal strFolderFilter As String = "*", _
                                            Optional ByVal blnReturnFullName As Boolean _
                                            ) As Variant

'// Returns an array of folder names that match strFolderFilter
'// Use argument to choose whether you want full paths or FolderNames only
'// If no matching folders are found, it returns Empty

'// Credits: adapted from function by John Walkenbach

'// Note: The strFolderFilter is NOT case sensitive

    Dim avarFolderArray() As Variant
    Dim lngFolderCount    As Long
    Dim strFolderName     As String

    On Error GoTo ErrHandler

    strStartFolder = fnstrGetSeparatoredPath(strStartFolder)

    If Not fnblnExistsFileFolder(strStartFolder) Then
        GoTo NoFoldersFound
    End If

    'If no folders in folder, exit the sub
    strFolderName = Dir(strStartFolder & strFolderFilter, vbDirectory)
    If Len(strFolderName) = 0 Then
        GoTo NoFoldersFound
    End If

    'Loop until no more matching folders are found
'(separate loops for marginal speed improvement)
    If blnReturnFullName Then
        Do Until Len(strFolderName) = 0
            'only list folders
            If GetAttr(strStartFolder & strFolderName) And vbDirectory Then
                lngFolderCount = lngFolderCount + 1
                ReDim Preserve avarFolderArray(1 To lngFolderCount)
                avarFolderArray(lngFolderCount) = strStartFolder & strFolderName
            End If
            strFolderName = Dir()
        Loop
    Else
        Do Until Len(strFolderName) = 0
            'only list folders
            If GetAttr(strStartFolder & strFolderName) And vbDirectory Then
                lngFolderCount = lngFolderCount + 1
                ReDim Preserve avarFolderArray(1 To lngFolderCount)
                avarFolderArray(lngFolderCount) = strFolderName
            End If
            strFolderName = Dir()
        Loop
    End If

    fnavarGet1dArrFolders_ByDir = avarFolderArray
Exit Function

ErrHandler:
    fnavarGet1dArrFolders_ByDir = Empty
Exit Function

NoFoldersFound:
    fnavarGet1dArrFolders_ByDir = Empty
End Function

Private Function fnblnExistsFileFolder(ByVal strFullName As String) As Boolean
'adapted from function written by Ken Puls (www.excelguru.ca)
    If Len(strFullName) Then
        On Error Resume Next
        fnblnExistsFileFolder = Len(Dir(strFullName, 31))
        On Error GoTo 0
    End If
End Function

Private Function fnstrGetSeparatoredPath(ByRef strPath As String, Optional ByVal blnInvert As Boolean) As String
'/ ensures folder path ends in path separator (aka trailing backslash)
'/ doesn't detect garbage input, requires a Path arg
    Dim blnChange As Boolean
    Const strcPATH_SEPARATOR As String = "\"

    If Len(strPath) Then
        blnChange = ((Right$(strPath, 1) = strcPATH_SEPARATOR) = blnInvert)
        If Not blnChange Then
            fnstrGetSeparatoredPath = strPath
        ElseIf Not blnInvert Then
            'add trailing separator
            fnstrGetSeparatoredPath = strPath & strcPATH_SEPARATOR
        Else
            'remove last character
            fnstrGetSeparatoredPath = Left$(strPath, Len(strPath) - 1)
        End If
    End If
End Function

@b2: Thank you.

@shg: You're welcome and many thanks for rep points.

@ mc84excel

You're welcome and thanks for the rep points.