基于VBA实现文件存入源文件夹两小时后自动迁移至目标文件夹

原脚本功能 #

现有VBA脚本实现的是将源文件夹中最新的第10个之后的文件批量迁移至目标文件夹，核心逻辑为统计文件数量，不足11个则退出；否则按文件时间倒序排序后迁移第5个及以后的文件。

需求更新 #

需要调整脚本逻辑，实现以下功能：

• 文件存入源文件夹两小时后自动迁移至目标文件夹，迁移时间精确匹配"存入时间+两小时"的时间点；
• 定时检查源文件夹：存在文件时逐个判断是否满足迁移条件，满足则立即迁移；无文件时每3-5分钟自动重新检查；
• 兼容.txt、.xml、.pdf等多种格式文件。

原代码 #

Sub MostRecentFyles_1062357()
Dim oFSO As Object, oFSOFolder As Object, oFSOFile As Object
Dim sFilePath As String, sFilePath2 As String
Dim arr() As Variant
Dim i As Long, kounter As Long
i = 1
kounter = 0
sFilePath = "E:\Source\"
sFilePath2 = "E:\Destination\"
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFSOFolder = oFSO.GetFolder(sFilePath)
kounter = oFSOFolder.Files.Count
If kounter < 11 Then Exit Sub
ReDim arr(1 To kounter, 1 To 2)
For Each oFSOFile In oFSOFolder.Files
    arr(i, 1) = oFSOFile.Name
    arr(i, 2) = FileDateTime(oFSOFile)
    i = i + 1
Next oFSOFile
arr = SortArrayZtoA(arr)

For i = 5 To UBound(arr)
    oFSO.movefile Source:=sFilePath & arr(i, 1), Destination:=sFilePath2 & arr(i, 1)
Next i
Set oFSOFile = Nothing
Set oFSOFolder = Nothing
Set oFSO = Nothing
Erase arr
End Sub

Function SortArrayZtoA(arr As Variant)
Dim i As Long, j As Long, n As Long
Dim Temp
For i = LBound(arr) To UBound(arr) - 1
    For j = i + 1 To UBound(arr)

        If CDate(arr(i, 2)) < CDate(arr(j, 2)) Then 'change less than symbol to greater than to sort A to Z

            For n = LBound(arr, 2) To UBound(arr, 2)
                Temp = arr(j, n)
                arr(j, n) = arr(i, n)
                arr(i, n) = Temp
            Next n
        End If
    Next j
Next i
SortArrayZtoA = arr
End Function

修改后的实现代码 #

Sub AutoMoveFilesAfterTwoHours()
    Dim oFSO As Object, oFSOFolder As Object, oFSOFile As Object
    Dim sSourcePath As String, sDestPath As String
    Dim checkInterval As Integer
    Dim currentTime As Date, fileCreateTime As Date
    
    ' 配置路径和检查间隔（3-5分钟随机）
    sSourcePath = "E:\Source\"
    sDestPath = "E:\Destination\"
    Randomize
    checkInterval = Int((5 - 3 + 1) * Rnd + 3) ' 生成3-5分钟的随机间隔
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    
    Do
        Set oFSOFolder = oFSO.GetFolder(sSourcePath)
        currentTime = Now()
        
        ' 遍历源文件夹所有文件
        For Each oFSOFile In oFSOFolder.Files
            ' 获取文件实际存入时间（DateCreated为文件创建时间，比FileDateTime更精准）
            fileCreateTime = oFSOFile.DateCreated
            
            ' 判断是否超过两小时，且是目标格式文件
            If DateDiff("n", fileCreateTime, currentTime) >= 120 Then
                Select Case LCase(oFSO.GetExtensionName(oFSOFile.Name))
                    Case "txt", "xml", "pdf"
                        ' 迁移文件，目标存在同名文件时自动覆盖
                        oFSO.MoveFile Source:=sSourcePath & oFSOFile.Name, Destination:=sDestPath & oFSOFile.Name
                End Select
            End If
        Next oFSOFile
        
        ' 释放对象
        Set oFSOFolder = Nothing
        
        ' 等待指定间隔后再次检查
        Application.Wait (Now() + TimeValue("00:" & checkInterval & ":00"))
    Loop ' 无限循环执行检查
End Sub

关键修改说明 #

1. 定时检查逻辑：通过Do...Loop无限循环结合Application.Wait实现定时检查，间隔随机取3-5分钟，避免固定间隔可能引发的系统资源冲突；
2. 迁移条件判断：使用DateDiff计算文件创建时间与当前时间的分钟差，达到120分钟（两小时）则触发迁移；
3. 格式过滤：通过GetExtensionName获取文件扩展名，仅处理指定的.txt、.xml、.pdf格式；
4. 精确时间基准：使用文件的DateCreated属性替代原代码的FileDateTime，确保以文件实际存入时间为基准计算两小时周期；
5. 无文件场景处理：即使源文件夹无文件，循环仍会持续执行，到设定间隔后自动重新检查。

内容的提问来源于stack exchange，提问作者Salman Shafi