Fastest way to get the file modified at the date of today

Question

I built this function in order to get the file which has been modified this day:

Public Function RetournerFichierModifieCeJour(PathDossier As String)
    Dim vaArray     As Variant
    Dim i           As Integer
    Dim oFile       As Object
    Dim oFSO        As Object
    Dim oFolder     As Object
    Dim oFiles      As Object

    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(PathDossier)
    Set oFiles = oFolder.Files

    If oFiles.Count = 0 Then Exit Function
    DoEvents
    For Each oFile In oFiles
    If Format(oFile.DateLastModified, "DD/MM/YYYY") = Format(Now(), "DD/MM/YYYY") Then
    Debug.Print "Found"
    End If
    DoEvents
    Next
End Function

But this is so low because I got 2000 file to browse... how would I improve this function in order to get the result faster ?

Answer 1

I have found that the old CMD DOS Dir command runs much faster than the filesystem object or vba DIR commands.

Accordingly you can try the following:

Note that the arguments for the DIR command will return the files in a date-sorted order, with the newest being at the top; so once you get a single entry that is earlier than today, you can exit the loop.

The files that "pass the test" are stored in a Collection object, for you to do with what you will.

Option Explicit
Public vFileList As Variant

Public Function RetournerFichierModifieCeJour(PathDossier As String)
    Dim vaArray     As Variant
    Dim I           As Long
    Dim V           As Variant
    Dim col         As Collection
    
    
GetDirTree PathDossier

Set col = New Collection
For I = 0 To UBound(vFileList)
    V = Left(vFileList(I), 10)
    If IsDate(V) Then
        If CDate(V) < (Date) Then Exit For
        col.Add Split(Mid(vFileList(I), 40), vbCr)(0)
    End If
Next I

End Function

Sub GetDirTree(PathDossier As String)
    Dim WSH As WshShell, lErrCode As Long
    Dim FSO As FileSystemObject, TS As TextStream
    Dim sTemp As String
    
    sTemp = Environ("Temp") & "\FileList.txt"
    
Set WSH = New WshShell

'note /U to enable Unicode output, as some names have char codes > 127 which are altered by redirection
lErrCode = WSH.Run("CMD /U /c dir """ & PathDossier & """ /A-D-S-H /O-D > " & sTemp, xlHidden, True)

If Not lErrCode = 0 Then
    MsgBox "Problem Reading Directory" & _
        vbLf & "Error Code " & lErrCode
    Exit Sub
End If
    

Set FSO = New FileSystemObject
Set TS = FSO.OpenTextFile(sTemp, ForReading, False, TristateTrue)

vFileList = Split(TS.ReadAll, vbLf)
TS.Close
FSO.DeleteFile sTemp
Set FSO = Nothing
    
End Sub

Oh, this routine took just under two (2) seconds to go through 37,000 files of which 104 passed the test.

Answer 2

Your code seems fine except for a few small issues. I'm not sure why your code is running that slow, maybe the files are on a shared drive or something similar? If disk access is slow, the code maybe the least significant factor in getting a speed up.

I'm returning a dictionary which will store the file name as the key, and a boolean to indicate if the file is new today or not. The speed shouldn't change that much, if you say, wanted to include the AbsolutePathName instead.

I changed the below code a little bit, it's processing 3000+ files in under 2 seconds.

Option Explicit

Public Function RetournerFichierModifieCeJour(PathDossier As String) As Object
    Dim vaArray     As Variant
    Dim i           As Integer
    Dim oFile       As Object
    Dim oFSO        As Object
    Dim oFolder     As Object
    Dim oFiles      As Object
    Dim Files  As Object
    
    Set Files = CreateObject("Scripting.Dictionary")
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(PathDossier)
    Set oFiles = oFolder.Files

    If oFiles.Count = 0 Then Exit Function
    Dim today As Date
    today = Format(Now(), "DD/MM/YYYY")
    
    For Each oFile In oFiles
        
        If Format(oFile.DateLastModified, "DD/MM/YYYY") = today Then
            Files.Add oFile.Name, True
        Else
            Files.Add oFile.Name, False
        End If
    Next
    
    Set RetournerFichierModifieCeJour = Files
    
End Function

Sub Example()
    Dim T As Double: T = Timer
    Dim dict As Object: Set dict = RetournerFichierModifieCeJour("C:\Users\Ryan\Desktop\New folder (2)")
    Debug.Print "This took: " & Timer - T & " seconds to process " & dict.Count & " files"
End Sub

My Results for a few runs:

This took: 1.515625 seconds to process 3128 files
This took: 1.453125 seconds to process 3128 files
This took: 1.4453125 seconds to process 3128 files
This took: 1.44921875 seconds to process 3128 files
This took: 1.44921875 seconds to process 3128 files

Answer 3

This is super rough code, but should point you in the right direction.

Run the benchmark:

• This approach (Windows API) took 2 seconds to read around 3000 files
• Using FSO took 27 seconds

Check for the credits in the comments.

! Becareful because code writes on the activecells.

Add the code to a module

Option Explicit

' Based on these two answers:
' https://www.mrexcel.com/archive/vba/printing-date-values-in-footers/
' https://stackoverflow.com/a/30512796/1521579

Private Declare PtrSafe Function FindClose Lib "kernel32" (ByVal hFindFile As LongPtr) As Long
Private Declare PtrSafe Function FindFirstFileW Lib "kernel32" (ByVal lpFileName As LongPtr, ByVal lpFindFileData As LongPtr) As LongPtr
Private Declare PtrSafe Function FindNextFileW Lib "kernel32" (ByVal hFindFile As LongPtr, ByVal lpFindFileData As LongPtr) As LongPtr

Private Declare PtrSafe Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long

Private Declare PtrSafe Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long

Private Type FILETIME
    dwLowDateTime  As Long
    dwHighDateTime As Long
End Type

Public Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Long
End Type

Const MAX_PATH  As Long = 260
Const ALTERNATE As Long = 14

' Can be used with either W or A functions
' Pass VarPtr(wfd) to W or simply wfd to A
Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime   As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime  As FILETIME
    nFileSizeHigh    As Long
    nFileSizeLow     As Long
    dwReserved0      As Long
    dwReserved1      As Long
    cFileName        As String * MAX_PATH
    cAlternate       As String * ALTERNATE
End Type

Private Const INVALID_HANDLE_VALUE As LongPtr = -1

Public Sub ListFiles()
    Dim hFile     As LongPtr
    Dim sFileName As String
    Dim wfd       As WIN32_FIND_DATA
    Dim counter   As Long
    
    sFileName = "C:\Nube\Ofiz\Batan - Radicados\*.*" ' Can be up to 32,767 chars
    
    hFile = FindFirstFileW(StrPtr(sFileName), VarPtr(wfd))
    
    Range("A1").Value = Now
    
    counter = 2
    
    If hFile <> INVALID_HANDLE_VALUE Then
        Do While FindNextFileW(hFile, VarPtr(wfd))
            'Debug.Print wfd.cFileName, FileDate(wfd.ftLastWriteTime)
            ActiveCell.Offset(counter, 0).Value = wfd.cFileName
            ActiveCell.Offset(counter, 1).Value = FileDate(wfd.ftLastWriteTime)
            If Format(FileDate(wfd.ftLastWriteTime), "DD/MM/YYYY") = Format(Now(), "DD/MM/YYYY") Then
                ActiveCell.Offset(counter, 2).Value = "Modified today!"
            End If
            counter = counter + 1
        Loop
        FindClose hFile
    End If
    
    Range("B1").Value = Now
    Range("C1").Formula = "=B1-A1"
    
End Sub

Function FileDate(FT As FILETIME) As String
    ' convert the FILETIME to LOCALTIME, then to SYSTEMTIME type
    Dim ST As SYSTEMTIME
    Dim LT As FILETIME
    Dim t As Long
    Dim ds As Double
    Dim ts As Double

    t = FileTimeToLocalFileTime(FT, LT)
    t = FileTimeToSystemTime(LT, ST)
    If t Then
        ds = DateSerial(ST.wYear, ST.wMonth, ST.wDay)
        ts = TimeSerial(ST.wHour, ST.wMinute, ST.wSecond)
        ds = ds + ts
        If ds > 0 Then
            FileDate = Format$(ds, "dd/mm/yy hh:mm:ss")
        Else
            FileDate = "(no date)"
        End If
    End If
End Function

Let me know if it works