Get list of sub-directories in VBA

Question

• I want to get a list of all sub-directories within a directory.
• If that works I want to expand it to a recursive function.

However my initial approach to get the subdirs fails. It simply shows everything including files:

sDir = Dir(sPath, vbDirectory)
Do Until LenB(sDir) = 0
    Debug.Print sDir
    sDir = Dir
Loop

The list starts with '..' and several folders and ends with '.txt' files.

---

EDIT:
I should add that this must run in Word, not Excel (many functions are not available in Word) and it is Office 2010.

---

EDIT 2:

One can determine the type of the result using

iAtt = GetAttr(sPath & sDir)
If CBool(iAtt And vbDirectory) Then
   ...
End If 

But that gave me new problems, so that I am now using a code based on Scripting.FileSystemObject.

Aprilaprile

I would like to stick with vba only. Not Scripting host or other dll bases tricks. And it shall work with Word of Office 2010. In the best case with Dir, since I would like to know why my example fails. – Aprilaprile

Answer 1

Updated July 2014: Added PowerShell option and cut back the second code to list folders only

The methods below that run a full recursive process in place of FileSearch which was deprecated in Office 2007. (The later two codes use Excel for output only - this output can be removed for running in Word)

1. Shell PowerShell
2. Using FSO with Dir for filtering file type. Sourced from this EE answer which sits behind the EE paywall. This is longer than what you asked for (a list of folders) but i think it is useful as it gives you an array of results to work further with
3. Using Dir. This example comes from my answer I supplied on another site

1. Using PowerShell to dump all folders below C:\temp into a csv file

Sub Comesfast()
X2 = Shell("powershell.exe Get-ChildItem c:\temp -Recurse | ?{ $_.PSIsContainer } | export-csv C:\temp\filename.csv", 1)
End Sub

2. Using FileScriptingObject to dump all folders below C:\temp into Excel

Public Arr() As String
Public Counter As Long

Sub LoopThroughFilePaths()
Dim myArr
Dim strPath As String
strPath = "c:\temp\"
myArr = GetSubFolders(strPath)
[A1].Resize(UBound(myArr, 1), 1) = Application.Transpose(myArr)
End Sub


Function GetSubFolders(RootPath As String)
Dim fso As Object
Dim fld As Object
Dim sf As Object
Dim myArr

Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(RootPath)
For Each sf In fld.SUBFOLDERS
    ReDim Preserve Arr(Counter)
    Arr(Counter) = sf.Path
    Counter = Counter + 1
    myArr = GetSubFolders(sf.Path)
Next
GetSubFolders = Arr
Set sf = Nothing
Set fld = Nothing
Set fso = Nothing
End Function

3 Using Dir

    Option Explicit

    Public StrArray()
    Public lngCnt As Long
    Public b_OS_XP As Boolean

    Public Enum MP3Tags
    '  See http://www.kixtart.org/forums/ubbthreads.php?ubb=showflat&Number=160880&page=1 for OS specific attribute lists
    XP_Artist = 16
    XP_AlbumTitle = 17
    XP_SongTitle = 10
    XP_TrackNumber = 19
    XP_RecordingYear = 18
    XP_Genre = 20
    XP_Duration = 21
    XP_BitRate = 22
    Vista_W7_Artist = 13
    Vista_W7_AlbumTitle = 14
    Vista_W7_SongTitle = 21
    Vista_W7_TrackNumber = 26
    Vista_W7_RecordingYear = 15
    Vista_W7_Genre = 16
    Vista_W7_Duration = 17
    Vista_W7_BitRate = 28
    End Enum

    Public Sub Main()
    Dim objws
    Dim objWMIService
    Dim colOperatingSystems
    Dim objOperatingSystem
    Dim objFSO
    Dim objFolder
    Dim Wb As Workbook
    Dim ws As Worksheet
    Dim strobjFolderPath As String
    Dim strOS As String
    Dim strMyDoc As String
    Dim strComputer As String

   'Setup Application for the user
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With    

    'reset public variables
    lngCnt = 0
    ReDim StrArray(1 To 10, 1 To 1000)

    ' Use wscript to automatically locate the My Documents directory
    Set objws = CreateObject("wscript.shell")
    strMyDoc = objws.SpecialFolders("MyDocuments")


    strComputer = "."
    Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
    Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
    For Each objOperatingSystem In colOperatingSystems
        strOS = objOperatingSystem.Caption
    Next

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If InStr(strOS, "XP") Then
        b_OS_XP = True
    Else
        b_OS_XP = False
    End If


    ' Format output sheet
    Set Wb = Workbooks.Add(1)
    Set ws = Wb.Worksheets(1)
    ws.[a1] = Now()
    ws.[a2] = strOS
    ws.[a3] = strMyDoc
    ws.[a1:a3].HorizontalAlignment = xlLeft

    ws.[A4:J4].Value = Array("Folder", "File", "Artist", "Album Title", "Song Title", "Track Number", "Recording Year", "Genre", "Duration", "Bit Rate")
    ws.Range([a1], [j4]).Font.Bold = True
    ws.Rows(5).Select
    ActiveWindow.FreezePanes = True


    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder(strMyDoc)

    ' Start the code to gather the files
    ShowSubFolders objFolder, True
    ShowSubFolders objFolder, False

    If lngCnt > 0 Then
        ' Finalise output
        With ws.Range(ws.[a5], ws.Cells(5 + lngCnt - 1, 10))
            .Value2 = Application.Transpose(StrArray)
            .Offset(-1, 0).Resize(Rows.Count - 3, 10).AutoFilter
            .Offset(-4, 0).Resize(Rows.Count, 10).Columns.AutoFit
        End With
        ws.[a1].Activate
    Else
        MsgBox "No files found!", vbCritical
        Wb.Close False
    End If

    ' tidy up

    Set objFSO = Nothing
    Set objws = Nothing

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .StatusBar = vbNullString
    End With
    End Sub

    Sub ShowSubFolders(ByVal objFolder, bRootFolder As Boolean)
    Dim objShell
    Dim objShellFolder
    Dim objShellFolderItem
    Dim colFolders
    Dim objSubfolder


    'strName must be a variant, as ParseName does not work with a string argument
    Dim strFname
    Set objShell = CreateObject("Shell.Application")
    Set colFolders = objFolder.SubFolders
    Application.StatusBar = "Processing " & objFolder.Path

    If bRootFolder Then
        Set objSubfolder = objFolder
        GoTo OneTimeRoot
    End If

    For Each objSubfolder In colFolders
        'check to see if root directory files are to be processed
    OneTimeRoot:
        strFname = Dir(objSubfolder.Path & "\*.mp3")
        Set objShellFolder = objShell.Namespace(objSubfolder.Path)
        Do While Len(strFname) > 0
            lngCnt = lngCnt + 1
            If lngCnt Mod 1000 = 0 Then ReDim Preserve StrArray(1 To 10, 1 To (lngCnt + 1000))
            Set objShellFolderItem = objShellFolder.ParseName(strFname)
            StrArray(1, lngCnt) = objSubfolder
            StrArray(2, lngCnt) = strFname
            If b_OS_XP Then
                StrArray(3, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_Artist)
                StrArray(4, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_AlbumTitle)
                StrArray(5, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_SongTitle)
                StrArray(6, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_TrackNumber)
                StrArray(7, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_RecordingYear)
                StrArray(8, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_Genre)
                StrArray(9, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_Duration)
                StrArray(10, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_BitRate)
            Else
                StrArray(3, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_Artist)
                StrArray(4, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_AlbumTitle)
                StrArray(5, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_SongTitle)
                StrArray(6, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_TrackNumber)
                StrArray(7, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_RecordingYear)
                StrArray(8, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_Genre)
                StrArray(9, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_Duration)
                StrArray(10, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_BitRate)
            End If
            strFname = Dir
        Loop
        If bRootFolder Then
            bRootFolder = False
            Exit Sub
        End If
        ShowSubFolders objSubfolder, False
    Next
    End Sub

Inhume

Nice example :) Damn! it doesn't let me vote it. Seems like already voted it on 26th march :D – Dobson

I would use a collection instead of redimming an array in a loop. excelmacromastery.com/excel-vba-collections – Catafalque

Answer 2

You would be better off with the FileSystemObject. I reckon.

To call this you just need, say: listfolders "c:\data"

Sub listfolders(startfolder)
''Reference Windows Script Host Object Model
''If you prefer, just Dim everything as Object
''and use CreateObject("Scripting.FileSystemObject")
Dim fs As New FileSystemObject
Dim fl1 As Folder
Dim fl2 As Folder

Set fl1 = fs.GetFolder(startfolder)

For Each fl2 In fl1.SubFolders
    Debug.Print fl2.Path
    listfolders fl2.Path
Next

End Sub

Chinfest

I think the question intent was to find all sub-directories once the initial issue of finding the first level sub-folders had been met, ie 'If that works I want to expand it to a recursive function" – Inhume

@Inhume That was not the way I read it. I read it as "if the code works" not "if the directory is found". In either case, the fact that the FileSystemObject finds directories will be a help, after all, the recursion line can easily be commented out then all the first level directories will be listed. – Chinfest

My bad - I had missed this line listfolders fl2.Path which delivered the recursion. +1 – Inhume

Not possible: Dim FS As New FileSystemObjectgives me "Type not defined" – Aprilaprile

@MatthiasPospiech Perhaps you did not see the comment directly above the Dim line that says which reference is required and suggests an alternative if you do not wish to add a reference? – Chinfest

FileSystemObject is not available on all machines, remember that. My workplace disabled it... – Thackeray

@Thackeray which is why he said " If you prefer, just Dim everything as Object and use CreateObject("Scripting.FileSystemObject") " – Trice

Answer 3

Here is a VBA solution, without using external objects.

Because of the limitations of the Dir() function you need to get the whole content of each folder at once, not while crawling with a recursive algorithm.

Function GetFilesIn(Folder As String) As Collection
  Dim F As String
  Set GetFilesIn = New Collection
  F = Dir(Folder & "\*")
  Do While F <> ""
    GetFilesIn.Add F
    F = Dir
  Loop
End Function

Function GetFoldersIn(Folder As String) As Collection
  Dim F As String
  Set GetFoldersIn = New Collection
  F = Dir(Folder & "\*", vbDirectory)
  Do While F <> ""
    If GetAttr(Folder & "\" & F) And vbDirectory Then GetFoldersIn.Add F
    F = Dir
  Loop
End Function

Sub Test()
  Dim C As Collection, F

  Debug.Print
  Debug.Print "Files in C:\"
  Set C = GetFilesIn("C:\")
  For Each F In C
    Debug.Print F
  Next F

  Debug.Print
  Debug.Print "Folders in C:\"
  Set C = GetFoldersIn("C:\")
  For Each F In C
    Debug.Print F
  Next F
End Sub

EDIT

This version digs into subfolders and returns full path names instead of returning just the file or folder name.

Do NOT run the test with on the whole C drive!!

Function GetFilesIn(Folder As String, Optional Recursive As Boolean = False) As Collection
  Dim F As String
  Set GetFilesIn = New Collection
  F = Dir(Folder & "\*")
  Do While F <> ""
    GetFilesIn.Add JoinPaths(Folder, F)
    F = Dir
  Loop

  If Recursive Then
    Dim SubFolder, SubFile
    For Each SubFolder In GetFoldersIn(Folder)
      If Right(SubFolder, 2) <> "\." And Right(SubFolder, 3) <> "\.." Then
        For Each SubFile In GetFilesIn(CStr(SubFolder), True)
          GetFilesIn.Add SubFile
        Next SubFile
      End If
    Next SubFolder
  End If
End Function

Function GetFoldersIn(Folder As String) As Collection
  Dim F As String
  Set GetFoldersIn = New Collection
  F = Dir(Folder & "\*", vbDirectory)
  Do While F <> ""
    If GetAttr(Folder & "\" & F) And vbDirectory Then GetFoldersIn.Add JoinPaths(Folder, F)
    F = Dir
  Loop
End Function

Function JoinPaths(Path1 As String, Path2 As String) As String
  JoinPaths = Replace(Path1 & "\" & Path2, "\\", "\")
End Function

Sub Test()
  Dim C As Collection, F

  Debug.Print
  Debug.Print "Files in C:\"
  Set C = GetFilesIn("C:\")
  For Each F In C
    Debug.Print F
  Next F

  Debug.Print
  Debug.Print "Folders in C:\"
  Set C = GetFoldersIn("C:\")
  For Each F In C
    Debug.Print F
  Next F

  Debug.Print
  Debug.Print "All files in C:\"
  Set C = GetFilesIn("C:\", True)
  For Each F In C
    Debug.Print F
  Next F
End Sub

Kissner

it doesnt dig into subfolders – Indiscerptible

@Indiscerptible I added a version that digs into subfolders. – Kissner

Answer 4

Here is a Simple version without using Scripting.FileSystemObject because I found it slow and unreliable. In particular the .Name method, was slowing everything down. Also I tested this in Excel but I don't think anything I used wouldn't be available in Word.

First some functions:

This joins two strings to create a file path, similar to os.path.join in python. It is useful for not needing to remember if you tacked on that "\" at the end of your path.

Const sep as String = "\"

Function pjoin(root_path As String, file_path As String) As String
    If right(root_path, 1) = sep Then
        pjoin = root_path & file_path
    Else
        pjoin = root_path & sep & file_path
    End If
End Function

This create a collection of sub items of root directory root_path

Function subItems(root_path As String, Optional pat As String = "*", _
                  Optional vbtype As Integer = vbNormal) As Collection
    Set subItems = New Collection
    Dim sub_item As String
    sub_item= Dir(pjoin(root_path, pat), vbtype)
    While sub_item <> ""
        subItems.Add (pjoin(root_path, sub_item))
        sub_item = Dir()
    Wend
End Function

This creates a collection of sub items in directory root_path that including folders and then removes items that are not folders from the collection. And it can optionally remove those nasty . and .. folders

Function subFolders(root_path As String, Optional pat As String = "", _
                    Optional skipDots As Boolean = True) As Collection
    Set subFolders = subItems(root_path, pat, vbDirectory)
    If skipDots Then
        Dim dot As String
        Dim dotdot As String
        dot = pjoin(root_path, ".")
        dotdot = dot & "."
        Do While subFolders.Item(1) = dot _
        Or subFolders.Item(1) = dotdot
            subFolders.remove (1)
            If subFolders.Count = 0 Then Exit Do
        Loop
    End If
    For i = subFolders.Count To 1 Step -1
        ' This comparison could be replaced by and `fileExists` function
        If Dir(subFolders.Item(i), vbNormal) <> "" Then
            subFolders.remove (i)
        End If
    Next i
End Function

Finally is the recursive search function based on someone else function from this site that used Scripting.FileSystemObject I haven't done any comparison tests between it and the original. If I find that post again I will link it. Note collec is passed by reference so create a new collection and call this sub to populate it. Pass vbType:=vbDirectory for all sub folders.

Sub walk(root_path As String, ByRef collec as Collection, Optional pat As String = "*" _
         Optional vbType as Integer = vbNormal)
    Dim subF as Collection
    Dim subD as Collection
    Set subF = subItems(root_path, pat, vbType)
    For Each sub_file In subF
        collec.Add sub_file 
    Next sub_file 
    Set subD = subFolders(root_path)
    For Each sub_folder In subD
        walk sub_folder , collec, pat, vbType
    Next sub_folder 
End Sub

Turret

Indeed .Name is very slow on the folder object – Haemostasis

Answer 5

Late answer, but posting for others who might have a similar problem.

I had a similar challenge but had the restriction of not being able to use FileSystemObject. Therefore, I wrote a Class library that makes heavy use of the Dir() function to parse all the files and folders in a specified directory. It requires you to set no references to additional libraries in the VBA IDE. Although I wrote it for Excel, I tested and verified it runs in Word also.

You can use it to print a list of all folders like this:

Sub PrintFilesAndFolders(Directory As DirectoryManager, Optional indent As String)
'Helper method

    Dim folder As DirectoryManager
    Dim newIndent As String
    
    For Each folder In Directory.Folders
        Debug.Print indent & "+ " & folder.Name
        newIndent = indent & "  "
        PrintFilesAndFolders folder, newIndent
    Next folder
    
End Sub

Sub LoopThroughAllFilesAndFolders()

    Dim dm As DirectoryManager
    
    Set dm = New DirectoryManager
    dm.Path = ThisDocument.Path & "\Sample Data Set"
    
    PrintFilesAndFolders dm

End Sub

The example documentation shows how you can modify that script to include files too if you wanted.

Thackeray

Answer 6

This pure Basic code works for me, using Dir() and a dynamic array for subdirectories paths.

This avoids usage of VBA object like Collection, Scripting.FileSystemObject...

'
' get direct subdirectory full paths under the given directory
'
' uses:
'   Dir(),GetAttr()
' inputs:
'   strDir: directory
'   arrPaths: array of found entry paths
' outputs:
'   arrPaths: array of found entry paths
'
Function GetDirectSubDirs(ByVal strDir As String, ByRef arrPaths()) As Long
'
  Dim i As Long, lEntry As Long
  Dim str1 As String
'
  i = 0
  lEntry = 0
'
  Do While (True)
    '
    If (lEntry = 0) Then
      str1 = Dir(strDir & "\" & "*", vbDirectory)
    Else
      str1 = Dir()
    End If
    '
    ' have no more entries:
    '
    If (str1 = "") Then
      Exit Do
    '
    ' ignore current or parent directory:
    '
    ElseIf ((str1 = ".") Or (str1 = "..")) Then
    '
    ' otherwise:
    '
    Else
      '
      ' get full path:
      '
      str1 = strDir & "\" & str1
      '
      ' save it if directory:
      '
      If (GetAttr(str1) And vbDirectory) Then
        ReDim Preserve arrPaths(i)
        arrPaths(i) = str1
        i = i + 1
      End If
    End If
    '
    ' count entries:
    '
    lEntry = lEntry + 1
    '
  Loop
'
  GetDirectSubDirs = i
End Function

'
' get recursively subdirectory full paths
'
' uses:
'   DoEvents(),UBound()
' inputs:
'   strDir: directory
'   arrPaths: array of found entry paths
' outputs:
'   arrPaths: array of found entry paths
'
Function GetSubDirsR(ByVal strDir As String, ByRef arrPaths()) As Long
'
  Dim i As Long, iup As Long, iupFound As Long
  Dim arrSubDirs()
'
  On Error Resume Next
'
  iupFound = UBound(arrPaths)
  If (Err.Number <> 0) Then
    iupFound = -1
    Err = 0
  End If
'
  On Error GoTo 0
'
' handle subdirectories:
'
  iup = GetDirectSubDirs(strDir, arrSubDirs) - 1
  For i = 0 To iup
    '
    ' this makes our code more interactive:
    '
    'DoEvents
    '
    iupFound = iupFound + 1
    ReDim Preserve arrPaths(iupFound)
    '
    arrPaths(iupFound) = arrSubDirs(i)
    '
    iupFound = GetSubDirsR(arrPaths(iupFound), arrPaths) - 1
    '
  Next
  GetSubDirsR = iupFound + 1
End Function

'
' just test it:
'
Sub Test()
'
  Dim i As Long, nFound As Long
  Dim strDir As String
  Dim arrPaths()
'
  strDir = "C:\temp"
  nFound = GetSubDirsR(strDir, arrPaths)
'
  For i = 0 To nFound - 1
    Debug.Print arrPaths(i)
  Next
'
End Sub

In GetDirectSubDirs(), we get at once the whole list of subdirectories, as Dir() calls cannot be embricated for different parent directories.

Mounting