VBA to return list of all files with a particular file extension across all a user's logical drives

Hello Experts,

I have an Front end/back end Access application where the end users can have multiple back end files. All these files end in ".eve". More frequently than I would like end users "forget' where the back end files have been created. I can get them a list of files on a logical drive (example C: drive) using command line window with:

CD C:\
dir *.eve /S >C:\SEMP\evefiles.txt

I am after a VBA routine to cycle through all their logical drives and list the .eve files in each drive/folder with  "Last Accessed" information. I am familiar with GetLogicalDriveStrings but can't put put it all together into a single routine an end user can call simply.
Who is Participating?
BenefordConnect With a Mentor Commented:
This should do what you need.

Option Compare Database
Option Explicit

Dim fso As New FileSystemObject
Dim fld As Folder

Private Declare Function GetLogicalDriveStrings Lib "kernel32" _
    Alias "GetLogicalDriveStringsA" _
    (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

' Taken from http://support.microsoft.com/kb/291573
Private Function GetDriveStrings() As String
    ' Wrapper for calling the GetLogicalDriveStrings API
    Dim result As Long          ' Result of our api calls
    Dim strDrives As String     ' String to pass to api call
    Dim lenStrDrives As Long    ' Length of the above string
    ' Call GetLogicalDriveStrings with a buffer size of zero to
    ' find out how large our stringbuffer needs to be
    result = GetLogicalDriveStrings(0, strDrives)
    strDrives = String(result, 0)
    lenStrDrives = result
    ' Call again with our new buffer
    result = GetLogicalDriveStrings(lenStrDrives, strDrives)
    If result = 0 Then
        ' There was some error calling the API
        ' Pass back an empty string
        ' NOTE - TODO: Implement proper error handling here
        GetDriveStrings = ""
        GetDriveStrings = strDrives
    End If
End Function

' adapted from https://support.microsoft.com/kb/185601/EN-US
Sub FindFile(ByVal sFol As String, sFile As String)
   Dim tFld As Folder, tFil As File, FileName As String
   Dim foundFile As String
   Dim foundDetail As String
   On Error GoTo Catch
   Set fld = fso.GetFolder(sFol)
   FileName = Dir(fso.BuildPath(fld.Path, sFile), vbNormal Or vbReadOnly) 'Or vbHidden Or vbSystem
   While Len(FileName) <> 0
      foundFile = fso.BuildPath(fld.Path, FileName)
      foundDetail = FileDateTime(foundFile)
      FileList.AddItem foundDetail & " -> " & foundFile  ' Load ListBox
      FileName = Dir()  ' Get next file
   lStatus.Caption = "Searching " & vbCrLf & fld.Path & "..."
   If fld.SubFolders.Count > 0 Then
      For Each tFld In fld.SubFolders
         FindFile tFld.Path, sFile
   End If
   Exit Sub
Catch:  FileName = ""
       Resume Next
End Sub

Private Sub bSearch_Click()
    Dim ds As String
    Dim i As Integer
    ds = GetDriveStrings
    For i = 1 To Len(ds) Step 4
        FindFile Mid(ds, i, 3), SearchFor
    Next i
End Sub

Private Sub Command44_Click()
    lStatus.Caption = ""
    While FileList.ListCount > 0
        FileList.RemoveItem (0)
End Sub

Open in new window

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.