Get list of sub-directories in VBA - 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.

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)
Shell PowerShell
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
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

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

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

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

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.