Question

要求
我想根据创建日期在给定日期范围内的给定文件夹（及其子文件夹）获取所有文件的列表

我的知识
我知道我可以使用以下方法遍历文件夹中的每个文件：

For Each oFile In oFolder.Files

或者我可以使用DIR做类似的事情，但是这两个选项都意味着我将遍历每个文件夹（和子文件夹）中的每个文件。

我的决议-到目前为止
我计划要做的是运行DOS命令（通过Sheel）并将所有文件（满足我的要求）的名称转换为文本文件，然后对这些文件执行任务< / p>

问题
有没有办法我可以获取所有文件的名称（递归地通过文件夹），而不是遍历每个文件夹中的所有文件？

Answer 1

使用DIR可以快速获取所需的所有文件，并且它可以递归工作。我不能确定DIR可以根据创建日期，所以我混有FSO这种方法筛选文件。我的表现不错。我能够在约8秒内返回约45,000个文件。

关于FolderPattern参数的快速说明。这实际上是文件夹或文件模式。因此，您可以传递要匹配的每个文件应存在的部分路径。您还可以使用通配符，例如*.*将返回所有文件，或*.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

Answer 2

实际上，有一种方法可以使用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

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

2 个答案: