Get list of files recursively based on a date range

Question

Requirement
I want to get a list of all files from a given folder (and it's sub folders) based on creation date being within a given date range

My Knowledge
I know I can loop through each file in a folder using:

For Each oFile In oFolder.Files

Or I can use DIR to do something similar but both these options mean that I will be looping through each file in every folder (and sub folders).

My Resolution - So Far
What I am planning to do is to run a DOS command (through Sheel) and get the names of all files (that meet my requirement) into a text file and then perform my tasks on these files

Question
Is there a way that I can just get the names of all files (recursively through the folders) rather then looping through all files in each folder?

Answer 1

There actually is a way to do this by using WMI and executing queries on CIM_DataFile. The subroutine below would recursively query each subfolder and gather files based on the CreationDate property.

Sub WMIGetFile()
Dim strComputer As String
Dim strDateFrom As String
Dim strDateTo As String
Dim fso, f, subf, oWMI, colFiles, cf

strComputer = "."
strDateFrom = "20180101000000.000000+00" ' 01/01/2018
strDateTo = "20191231000000.000000+00"   ' 12/31/2019

Set oWMI = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")

Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.getFolder("C:\FolderName\")

For Each subf In f.SubFolders
    Debug.Print subf.Path
    Set colFiles = oWMI.ExecQuery( _
        "SELECT * FROM CIM_DataFile" & _
        " WHERE Drive = 'C:' AND Path = '\\" & Replace(Right(subf.Path, Len(subf.Path) - 3), "\", "\\") & "\\'" & _
        " AND CreationDate >= '" & strDateFrom & "'" & _
        " AND CreationDate <= '" & strDateTo & "'")

        For Each cf In colFiles
            Debug.Print cf.Name
        Next cf

    Set colFiles = Nothing

Next subf

End Sub

Path is formatted with \\ instead of \ as a path delimiter starting from the drive specified in Drive, hence the Replace(Right()) method.

Also worth noting that WMI dates are formatted as strings by yyyymmddhhmmss.000000.

EDIT:

My brain missed the part where you need to execute this on the main folder as well. In that case, I'd just define it as a function and pass the parameters like this

Sub WMIGetFile()
    Dim fso, f, subf, oWMI
    Dim strComputer As String

    strComputer = "."

    Set oWMI = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.getFolder("C:\FolderName\")

    QueryCIMDATAFILE oWMI, f

    For Each subf In f.SubFolders
        QueryCIMDATAFILE oWMI, subf
    Next subf

End Sub


Function QueryCIMDATAFILE(conn, path)
    Dim colFiles, cf

    Dim strDateFrom As String
    Dim strDateTo As String


    strDateFrom = "20180101000000.000000+00" ' 01/01/2018
    strDateTo = "20191231000000.000000+00"   ' 12/31/2019

    Set colFiles = conn.ExecQuery( _
        "SELECT * FROM CIM_DataFile" & _
        " WHERE Drive = 'C:' AND Path = '\\" & Replace(Right(path.path, Len(path.path) - 3), "\", "\\") & "\\'" & _
        " AND CreationDate >= '" & strDateFrom & "'" & _
        " AND CreationDate <= '" & strDateTo & "'")

    For Each cf In colFiles
        Debug.Print cf.Name
    Next cf

    Set colFiles = Nothing
End Function

Answer 2

Using DIR is fast to get all the files you need up front, and it works recursively. I'm unsure if DIR can filter files based on create date, so I mixed that approach with FSO. I'm getting good performance. I'm able to return ~45,000 or so files in ~8 seconds.

A quick note on the FolderPattern parameter. This is really a Folder or File Pattern. So you can pass in part of the path that should exist for each file you want to match. You can also use wildcards, for example *.* will return all files, or *.txt would return all text files.

 'Adapted from --> https://stackoverflow.com/a/31132876/4839827
Public Sub GetAllFilesMatchingPattern(StartingFolder As String, FolderPattern As String, StartingDate As Date, EndingDate As Date)
    If Right$(StartingFolder, 1) <> "\" Then StartingFolder = StartingFolder & "\"
    Dim StandardOutput      As String
    Dim ws                  As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
    Dim Files               As Variant
    Dim FileArr             As Variant
    Static fso              As Object
    Dim FileCreationDate    As Date
    Dim j                   As Long

    If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject")

    StandardOutput = CreateObject("WScript.Shell").Exec("CMD /C DIR """ & StartingFolder & FolderPattern & """ /S /B /A:-D").StdOut.ReadAll

    'Exit if there was no output
    If StandardOutput = vbNullString Then Exit Sub

    'Get all files that match initial filter
    Files = Split(StandardOutput, vbCrLf)
    ReDim FileArr(LBound(Files) To UBound(Files))
    j = LBound(Files)

    'Only include those which still exist and are in date range
    For i = LBound(Files) To UBound(Files)
        FileCreationDate = #1/1/1900#
        If fso.FileExists(Files(i)) Then FileCreationDate = fso.GetFile(Files(i)).DateCreated

        If FileCreationDate >= StartingDate And FileCreationDate <= EndingDate And FileCreationDate <> #1/1/1900# Then
            FileArr(j) = Files(i)
            j = j + 1
        End If
    Next

    ReDim Preserve FileArr(j)
    'Dump Data
    ws.Range("A1").Resize(UBound(Files), 1).Value2 = Application.Transpose(FileArr)
End Sub

Sub Example()
    GetAllFilesMatchingPattern "E:\", "*.*", #1/1/2000#, #1/29/2019#
End Sub