Is there a faster way to list all files in a folder to a table using MS Access VBA?

I've been testing with some code I found online but it takes a while to get through all the files I have (~34,000 files). Just curious if there is a faster way to accomplish this or if that's about as fast as it gets.

Thanks!

Here is the current code:
I'm running the sub runListFiles
Option Compare Database

Option Explicit

'list files to tables
'http://allenbrowne.com/ser-59alt.html

Dim gCount As Long ' added by Crystal

Sub runListFiles()
    'Usage example.
    Dim strPath As String _
    , strFileSpec As String _
    , booIncludeSubfolders As Boolean
    
    strPath = "\\sfile0\e\cnc\NC-PROGRAMS\"
    strFileSpec = "*.*"
    booIncludeSubfolders = True
    
    ListFilesToTable "\\sfile0\e\cnc\NC-PROGRAMS\", strFileSpec, booIncludeSubfolders
    ListFilesToTable "\\sfile0\e\cnc\NC-TOOLLIST\", strFileSpec, booIncludeSubfolders
    ListFilesToTable "\\sfile0\e\cnc\OLD NC PROGRAMS\", strFileSpec, booIncludeSubfolders
    ListFilesToTable "\\sfile0\e\cnc\OLD NC TOOL LISTS\", strFileSpec, booIncludeSubfolders

    ListFilesToTable "\\sfile0\e\cnc\JOB-PROGRAMS\", strFileSpec, booIncludeSubfolders
    ListFilesToTable "\\sfile0\e\cnc\JOB-TOOLLIST\", strFileSpec, booIncludeSubfolders
    ListFilesToTable "\\sfile0\e\cnc\OLD JOB PROGRAMS\", strFileSpec, booIncludeSubfolders
    ListFilesToTable "\\sfile0\e\cnc\OLD JOB TOOL LISTS\", strFileSpec, booIncludeSubfolders
    
    MsgBox "Done"
End Sub

'crystal modified parameter specification for strFileSpec by adding default value
Public Function ListFilesToTable(strPath As String _
    , Optional strFileSpec As String = "*.*" _
    , Optional bIncludeSubfolders As Boolean _
    )
On Error GoTo Err_Handler
    'Purpose:   List the files in the path.
    'Arguments: strPath = the path to search.
    '           strFileSpec = "*.*" unless you specify differently.
    '           bIncludeSubfolders: If True, returns results from subdirectories of strPath as well.
    'Method:    FilDir() adds items to a collection, calling itself recursively for subfolders.
    
    Dim colDirList As New Collection
    Dim varitem As Variant
    Dim rst As DAO.Recordset
    
   Dim mStartTime As Date _
      , mSeconds As Long _
      , mMin As Long _
      , mMsg As String
      
   mStartTime = Now()
   '--------
    
    Call FillDirToTable(colDirList, strPath, strFileSpec, bIncludeSubfolders)
      
'   mSeconds = DateDiff("s", mStartTime, Now())
'
'   mMin = mSeconds \ 60
'   If mMin > 0 Then
'      mMsg = mMin & " min "
'      mSeconds = mSeconds - (mMin * 60)
'   Else
'      mMsg = ""
'   End If
'
'   mMsg = mMsg & mSeconds & " seconds"
'
'   MsgBox "Done adding " & Format(gCount, "#,##0") & " files from " & strPath _
'      & IIf(Len(Trim(strFileSpec)) > 0, " for file specification --> " & strFileSpec, "") _
'      & vbCrLf & vbCrLf & mMsg, , "Done"
  
Exit_Handler:
   SysCmd acSysCmdClearStatus
   '--------
    
    Exit Function

Err_Handler:
    MsgBox "Error " & Err.Number & ": " & Err.Description, , "ERROR"
    
    'remove next line after debugged -- added by Crystal
    Stop: Resume 'added by Crystal
    
    Resume Exit_Handler
End Function

Private Function FillDirToTable(colDirList As Collection _
    , ByVal strFolder As String _
    , strFileSpec As String _
    , bIncludeSubfolders As Boolean)
   
    'Build up a list of files, and then add add to this list, any additional folders
    On Error GoTo Err_Handler
    
    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant
    Dim strSQL As String

    'Add the files to the folder.
    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
    Do While strTemp <> vbNullString
         gCount = gCount + 1
         SysCmd acSysCmdSetStatus, gCount
         strSQL = "INSERT INTO Files " _
          & " (FName, FPath) " _
          & " SELECT """ & strTemp & """" _
          & ", """ & strFolder & """;"
          Debug.Print strTemp
         CurrentDb.Execute strSQL
        colDirList.Add strFolder & strTemp
        strTemp = Dir
    Loop

    If bIncludeSubfolders Then
        'Build collection of additional subfolders.
        strTemp = Dir(strFolder, vbDirectory)
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then
                    colFolders.Add strTemp
                End If
            End If
            strTemp = Dir
        Loop
        'Call function recursively for each subfolder.
        For Each vFolderName In colFolders
            Call FillDirToTable(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True)
        Next vFolderName
    End If

Exit_Handler:
    
    Exit Function

Err_Handler:
    strSQL = "INSERT INTO Files " _
    & " (FName, FPath) " _
    & " SELECT ""  ~~~ ERROR ~~~""" _
    & ", """ & strFolder & """;"
    CurrentDb.Execute strSQL
    
    Resume Exit_Handler
End Function

Public Function TrailingSlash(varIn As Variant) As String
    If Len(varIn) > 0& Then
        If Right(varIn, 1&) = "\" Then
            TrailingSlash = varIn
        Else
            TrailingSlash = varIn & "\"
        End If
    End If
End Function

Open in new window

LVL 2
Jarred MeyerProduction ManagerAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

PatHartmanCommented:
The biggest hit for this procedure is running a separate insert query for each file name.  This technique requires running 34,000!!!!! queries.  You should change that to DAO code that opens a recordset and then inside the loop does an .addNew for each table.

Here's some code from one of my apps that I think does what you need.  Please let me know if anything is missing.
Option Compare Database
Option Explicit
 
Dim fso As New FileSystemObject
Dim qdDAO As DAO.QueryDef
Dim rsDAO As DAO.Recordset
Dim db As DAO.DataBase

Public Sub ShowFileListWithSubdirectories_JustList(sDir As String, sSearchString As String)
   Dim nDirs As Long, nFiles As Long, lSize As Currency
On Error GoTo Err_Proc
   If IsNull(sDir) Or IsNull(sSearchString) Then
        MsgBox "Directory and file type are both required", vbOKOnly + vbInformation
        Exit Sub
    End If
    
    ' Open recordset which will be used to add rows
    Set db = CurrentDb()
    Set qdDAO = db.QueryDefs!qCaptureEndorsementFileNames
    Set rsDAO = qdDAO.OpenRecordset

   lSize = FindFile_JustList(sDir, sSearchString, nDirs, nFiles)
   'MousePointer = vbDefault
   MsgBox Str(nFiles) & " files found in" & Str(nDirs) & _
          " directories", vbInformation
   MsgBox "Total Size = " & lSize & " bytes"
   
Exit_Proc:
 
   Set rsDAO = Nothing
   
   Exit Sub
Err_Proc:
    MsgBox Err.Number & "--" & Err.Description, vbCritical
    GoTo Exit_Proc
End Sub
Public Function FindFile_JustList(ByVal sFol As String, sFile As String, _
    nDirs As Long, nFiles As Long) As Currency
    Dim tFld As Scripting.folder
    Dim tFil As Scripting.file
    Dim FileName As String
    Dim filefolder
    Dim sPath As String
        
    On Error GoTo Catch

    FileCounter = 0
   
   Set tFld = fso.GetFolder(sFol)
   FileName = Dir(fso.BuildPath(tFld.Path, sFile), vbNormal Or _
                  vbHidden Or vbSystem Or vbReadOnly)
   While Len(FileName) <> 0
      FindFile_JustList = FindFile_JustList + FileLen(fso.BuildPath(tFld.Path, _
      FileName))
      nFiles = nFiles + 1
      sPath = tFld.Path & "\" & FileName
'      Debug.Print sPath
      
      rsDAO.AddNew
        rsDAO!PathName = tFld.Path
        rsDAO!FileName = FileName
        rsDAO!ChangeDt = tFld.DateLastModified
        rsDAO!CreateDT = tFld.DateCreated
      rsDAO.Update
      
      FileName = Dir()  ' Get next file
      DoEvents
   Wend
   'Me.Label1 = "Searching " & vbCrLf & tFld.Path & "..."
   'Me.Repaint
   nDirs = nDirs + 1
   If tFld.SubFolders.Count > 0 Then
      For Each tFld In tFld.SubFolders
         DoEvents
         FindFile_JustList = FindFile_JustList + FindFile_JustList(tFld.Path, sFile, nDirs, nFiles)
      Next
   End If

   Exit Function
Catch:  FileName = ""
       Resume Next
End Function

Open in new window

Jarred MeyerProduction ManagerAuthor Commented:
Thanks a bunch for the help!

I'm hung up trying to input my own recordset.

Rather than  using:
Set qdDAO = db.QueryDefs!qCaptureEndorsementFileNames

I'm trying to call a linked SQL table dbo_FileIndex

I can't seem to figure out how to call that up instead of the querydefs.

Thanks again for the information!
Jarred MeyerProduction ManagerAuthor Commented:
I figured it out. Also, I switched to a local table for now to compare your code with the original code I was using. Unfortunately the code you provided was quite a bit slower. What you said made since and I was kind of thinking that may have been happening (running a query 30K times, however it was considerably faster.

Running both codes on just the first directory (10,459 files):
Original Code I'm using took 40 seconds.
Your Code took 2 minutes & 38 seconds.

Here is how I switched out the querydefs part of the code for my table in case this has something to do with the time it's taking to run the query:
Public Sub ShowFileListWithSubdirectories_JustList(sDir As String, sSearchString As String)
   Dim nDirs As Long, nFiles As Long, lSize As Currency
On Error GoTo Err_Proc
   If IsNull(sDir) Or IsNull(sSearchString) Then
        MsgBox "Directory and file type are both required", vbOKOnly + vbInformation
        Exit Sub
    End If
    
    ' Open recordset which will be used to add rows
    Set db = CurrentDb()
'    'Set qdDAO = db.QueryDefs!qCaptureEndorsementFileNames
'    Set qdDAO = "('dbo_tblFileIndex', dbOpenDynaset, dbSeeChanges)"
'    Set rsDAO = qdDAO.OpenRecordset
    Set rsDAO = db.OpenRecordset("Files")
   lSize = FindFile_JustList(sDir, sSearchString, nDirs, nFiles)
   'MousePointer = vbDefault
   MsgBox Str(nFiles) & " files found in" & Str(nDirs) & _
          " directories", vbInformation
   MsgBox "Total Size = " & lSize & " bytes"
   
Exit_Proc:
 
   Set rsDAO = Nothing
   
   Exit Sub
Err_Proc:
    MsgBox Err.Number & "--" & Err.Description, vbCritical
    GoTo Exit_Proc
End Sub

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
PatHartmanCommented:
There are two things different in the method I used.  The first is using FSO and a recursive call to read through a directory and all its subdirectories.  The second is using a DAO recordset with the .addnew method rather than running separate append queries.

Maybe combining the two would be best.  Use the Access method to read the directory instead of FSO.  It could be that FSO is slower than the Access method.  Or you might not actually need to process subdirectories and so you can eliminate that recursive call.   I've never processed a directory with so many files that there was an issue.
Jarred MeyerProduction ManagerAuthor Commented:
Seemed to run the fastest
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Access

From novice to tech pro — start learning today.