根据日期范围递归获取文件列表

实际上,有一种方法可以通过使用 WMI 以及在上执行查询 CIM_DataFile . 下面的子例程将递归查询每个子文件夹,并根据 CreationDate 所有物

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 格式为 \\ 而不是 \ 作为从中指定的驱动器开始的路径分隔符 Drive 因此 Replace(Right())

还值得注意的是,WMI日期的格式为字符串 yyyymmddhhmmss.000000

编辑:

我的大脑也错过了你需要在主文件夹上执行这个的部分。在这种情况下,我将它定义为一个函数,并像这样传递参数

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

使用DIR可以快速地预先获取所需的所有文件,并且可以递归地工作。我不确定DIR是否可以根据创建日期过滤文件,所以我将这种方法与FSO混合使用。我的表现很好。我能够在8秒内返回大约45000个文件。

*.* *.txt 将返回所有文本文件。

 '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