MS Access – VBA – Import Listing of Sub-Directories Into A Table

I was recently asked how one could modify the code found in my MS Access – VBA – Import Directory Listing Into A Table post to get a listing of sub-directories/folders instead of a listing of files. The solution is pretty straight forward, as you can see for yourself below:

'---------------------------------------------------------------------------------------
' Procedure : ListSubDirectories
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Create a listing of directories within the specified directory and
'               append them to a table
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sDirectory: Full path of the root directory to extract a listing of subdirectories
'               from including trailing \
'
' Usage:
' ~~~~~~
' Call ListSubDirectories("c:\")
' Call ListSubDirectories("c:\users\")
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2016-07-06              Initial Release - Answer website question
'---------------------------------------------------------------------------------------
Public Sub ListSubDirectories(sDirectory As String)
    On Error GoTo Error_Handler
    Dim db                    As Database
    Dim sSQL                  As String
    Dim MyFolder              As String

    Set db = CurrentDb

    MyFolder = Dir$(sDirectory & "*", vbDirectory)
    Do While MyFolder <> ""
        If GetAttr(sDirectory & MyFolder) And vbDirectory Then
            Debug.Print MyFolder
            sSQL = "INSERT INTO [YourTableName] (YourTableFieldName) VALUES('" & MyFolder & "');"
            db.Execute sSQL, dbFailOnError
            'dbs.RecordsAffected 'could be used to validate that the
            'query actually worked
        End If
        MyFolder = Dir$
    Loop

Error_Handler_Exit:
    On Error Resume Next
    Set db = Nothing
    Exit Sub

Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: ListSubDirectories" & vbCrLf & _
           "Error Description: " & Err.Description, vbCritical, _
           "An Error has Occurred!"
    Resume Error_Handler_Exit
End Sub

I hope this helps someone!

9 responses on “MS Access – VBA – Import Listing of Sub-Directories Into A Table”

Charles DiGiovanna July 30, 2017 at 2:26 pm

No matter what I’ve done I cannot get MyFile to return anything but “”.
My directory is C:\Windows\Documents\health and there are a number of sub directories and many files in them.
The path is C:\Documents\health

Charles DiGiovanna July 30, 2017 at 2:27 pm

MyFile shows “”

Daniel Pineault Post authorJuly 31, 2017 at 1:46 pm

There is no MyFile variable in the code listed on this page. Could you give more detail as to what code you are running, how you are calling it, etc.

Chari April 16, 2020 at 5:04 am

I get this error:

Compile Error:
Expected user-defined type, not project

This code is highlighted in VBA
Dim db As Database

Daniel Pineault Post authorApril 16, 2020 at 9:49 am
You could try
```
Dim db As DAO.Database
```

Didier Van Acker February 7, 2021 at 1:37 pm

Hi Daniel,
Thanks for your coding, it helped me a lot already.
However, at this time I’m a bit lost.
I use your code for listing files (FF_ListFilesInDir) and this one for listing sub directories. But seem to be unable to get it mixed together.
My goal is to have a code to read a main directory, read all files and write them to a table, and then also read every subfolder, and do the same.
So: For each folder in folder X read files and subfolders and write them to tblfilesandfolders.( file, folder, subfolder, full path)
So read the complete tree structure of a folder and write it to a table (without the . and .. )
I tried to combine your codes, but get nowhere with my limited programming skill. Could you help out?

I have a searchbox where I can search the folder I want to explore.

I also tried this code if found somewhere else online : http://allenbrowne.com/ser-59.html , but I get an error if I use a networkdrive.
With your code, network seems no problem.

I’m probably overthinking it, therefore I just wanted to ask.

Best
D.

Daniel Pineault Post authorFebruary 7, 2021 at 4:47 pm

The issue with the above, as I found out the hard way, is that you can’t use Dir recursively.

So you need to turn to an alternate approach. Here’s some sample code I put together

Dim oFSO                   As Object

' ListDirs "C:\temp\", , false      -> list all files in folder
' ListDirs "C:\temp\"               -> list all files in folder & subfolders
' ListDirs "C:\temp\", "xls", false -> list all xls files in folder
' ListDirs "C:\temp\", "xls"        -> list all xls files in folder & subfolders
Public Function ListDirs(ByVal sPath As String, _
                         Optional sExt As String = "*", _
                         Optional bListSubDirs As Boolean = True)
10        On Error GoTo Error_Handler
          Dim oFldr                 As Object
          Dim oFile                 As Object
          Dim oSubFldr              As Object
          Dim bHeader               As Boolean

20        If Right(sPath, 1) <> "\" Then sPath = sPath & "\"


30        If oFSO Is Nothing Then Set oFSO = CreateObject("Scripting.FileSystemObject")
40        Set oFldr = oFSO.GetFolder(sPath)

50        If sExt <> "*" Then
60            For Each oFile In oFldr.Files
70                If oFSO.GetExtensionName(sPath & oFile.Name) = sExt Then
80                    If bHeader = False Then
90                        Debug.Print sPath
100                       bHeader = True
110                   End If
120                   Debug.Print , oFile.Name    'Size, DateLastModified, ...
130               End If
140           Next oFile
150       Else
160           Debug.Print sPath
170           For Each oFile In oFldr.Files
180               Debug.Print , oFile.Name
190           Next oFile
200       End If

210       If bListSubDirs = True Then    'Process sub directories
220           For Each oSubFldr In oFldr.SubFolders
230               Call ListDirs(oSubFldr.Path, sExt)
240           Next oSubFldr
250       End If

Error_Handler_Exit:
260       On Error Resume Next
270       If Not oSubFldr Is Nothing Then Set oSubFldr = Nothing
280       If Not oFldr Is Nothing Then Set oFldr = Nothing
290       If Not oFile Is Nothing Then Set oFile = Nothing
          '    If Not FSO Is Nothing Then Set FSO = Nothing 'Global Variable don't Reset
300       Exit Function

Error_Handler:
310       MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
                 "Error Number: " & Err.Number & vbCrLf & _
                 "Error Source: ListDirs" & vbCrLf & _
                 "Error Description: " & Err.Description & _
                 Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
                 , vbOKOnly + vbCritical, "An Error has Occured!"
320       Resume Error_Handler_Exit
End Function

Daniel Pineault Post authorFebruary 7, 2021 at 5:19 pm

Here’s another version closer to the original in the sense that at the end you get an array. I’ve included a small test procedure at the end which illustrates its usage.

Dim oFSO                      As Object
Dim aFiles()                  As String
Dim i                         As Long

' ListDirs "C:\temp\", , false      -> list all files in folder
' ListDirs "C:\temp\"               -> list all files in folder & subfolders
' ListDirs "C:\temp\", "xls", false -> list all xls files in folder
' ListDirs "C:\temp\", "xls"        -> list all xls files in folder & subfolders
Public Function ListDirs(ByVal sPath As String, _
                         Optional sExt As String = "*", _
                         Optional bListSubDirs As Boolean = True)
10        On Error GoTo Error_Handler
          Dim oFldr                 As Object
          Dim oFile                 As Object
          Dim oSubFldr              As Object
          Dim bHeader               As Boolean

20        If Right(sPath, 1) <> "\" Then sPath = sPath & "\"


30        If oFSO Is Nothing Then Set oFSO = CreateObject("Scripting.FileSystemObject")
40        Set oFldr = oFSO.GetFolder(sPath)

50        If sExt <> "*" Then
60            For Each oFile In oFldr.Files
70                If oFSO.GetExtensionName(sPath & oFile.Name) = sExt Then
80                    ReDim Preserve aFiles(i)
90                    aFiles(i) = oFile.Name
100                   i = i + 1
110               End If
120           Next oFile
130       Else
140           Debug.Print sPath
150           For Each oFile In oFldr.Files
160               ReDim Preserve aFiles(i)
170               aFiles(i) = oFile.Name
180               i = i + 1
190           Next oFile
200       End If

210       If bListSubDirs = True Then    'Process sub directories
220           For Each oSubFldr In oFldr.SubFolders
230               Call ListDirs(oSubFldr.Path, sExt)
240           Next oSubFldr
250       End If

Error_Handler_Exit:
260       On Error Resume Next
270       If Not oSubFldr Is Nothing Then Set oSubFldr = Nothing
280       If Not oFldr Is Nothing Then Set oFldr = Nothing
290       If Not oFile Is Nothing Then Set oFile = Nothing
          '    If Not FSO Is Nothing Then Set FSO = Nothing 'Global Variable don't Reset
300       Exit Function

Error_Handler:
310       MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
                 "Error Number: " & Err.Number & vbCrLf & _
                 "Error Source: ListDirs" & vbCrLf & _
                 "Error Description: " & Err.Description & _
                 Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
                 , vbOKOnly + vbCritical, "An Error has Occured!"
320       Resume Error_Handler_Exit
End Function


Sub TestListDir()
    Dim j                     As Long

    Call ListDirs("C:\temp\", "xls")
    For j = 0 To (i - 1)
        Debug.Print aFiles(j)
    Next j

    Erase aFiles
    i = 0
End Sub

I hope this helps you out.

Dumitru August 4, 2021 at 1:15 am

Hello Daniel,
It’s possible to make some changes to your code in order to read also the empty folders?
Thank you.