为按修改时间移动文件的VBA代码添加两小时延迟定时器

现有VBA代码可移动文件夹中最旧的单个文件，当前需求升级为：每个文件需在其修改时间之后两小时再被移动——即文件修改时间加两小时后，才触发移动操作，且自动循环处理符合条件的文件。

原代码 #

Function OldestFile(strFold As String) As String
    Dim FSO As Object, Folder As Object, File As Object, oldF As String
    Dim lastFile As Date: lastFile = Now
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(strFold)

    For Each File In Folder.Files
        If File.DateLastModified < lastFile Then
            lastFile = File.DateLastModified: oldF = File.Name
        End If
    Next
    OldestFile = oldF
End Function

Sub MoveOldestFile()
    Dim FromPath As String, ToPath As String, fileName As String

    FromPath = "E:\Source\"
    ToPath = "E:\Destination\"

    fileName = OldestFile(FromPath)

    If Dir(ToPath & fileName) = "" Then
        Name FromPath & fileName As ToPath & fileName
    Else
        MsgBox "File """ & fileName & """ already moved..."
    End If
End Sub

修改后的完整代码 #

Dim nextRunTime As Date

Function EligibleOldestFile(strFold As String) As String
    Dim FSO As Object, Folder As Object, File As Object, eligibleF As String
    Dim oldestEligibleDate As Date
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(strFold)
    
    ' 初始化最早符合条件的时间为未来值，确保能找到更小的时间
    oldestEligibleDate = DateAdd("h", 2, Now)
    
    For Each File In Folder.Files
        ' 判断文件修改时间加2小时是否已过，且是目前找到的最旧文件
        If DateAdd("h", 2, File.DateLastModified) <= Now And File.DateLastModified < oldestEligibleDate Then
            oldestEligibleDate = File.DateLastModified
            eligibleF = File.Name
        End If
    Next
    EligibleOldestFile = eligibleF
End Function

Sub MoveEligibleFile()
    Dim FromPath As String, ToPath As String, fileName As String
    FromPath = "E:\Source\"
    ToPath = "E:\Destination\"
    
    fileName = EligibleOldestFile(FromPath)
    
    If fileName <> "" Then
        If Dir(ToPath & fileName) = "" Then
            Name FromPath & fileName As ToPath & fileName
            Debug.Print "已移动文件: " & fileName & " | 移动时间: " & Now
        Else
            Debug.Print "文件已存在于目标路径: " & fileName
        End If
    End If
    
    ' 设置下一次检查时间（这里设为5分钟后，可自行调整）
    nextRunTime = Now + TimeValue("00:05:00")
    Application.OnTime nextRunTime, "MoveEligibleFile"
End Sub

Sub StartFileMovement()
    ' 启动自动检查任务
    nextRunTime = Now + TimeValue("00:00:10") ' 10秒后首次执行
    Application.OnTime nextRunTime, "MoveEligibleFile"
    MsgBox "文件自动移动任务已启动，保持Excel窗口打开以持续运行。"
End Sub

Sub StopFileMovement()
    ' 停止自动检查任务
    On Error Resume Next
    Application.OnTime nextRunTime, "MoveEligibleFile", , False
    On Error GoTo 0
    MsgBox "文件自动移动任务已停止。"
End Sub

关键改动说明 #

1. EligibleOldestFile函数：

   • 新增条件DateAdd("h", 2, File.DateLastModified) <= Now，只筛选出修改时间已超过两小时的文件
   • 从符合条件的文件中，找出最旧的那个作为待移动文件

2. 自动定时机制：

   • 使用Application.OnTime实现循环触发，每次移动完成后，设置下一次检查时间（示例为5分钟，可根据需求调整）
   • 新增StartFileMovement和StopFileMovement子程序，用于启动/停止自动任务

3. 日志与提示优化：

   • 用Debug.Print输出操作日志，方便查看执行情况
   • 启动/停止任务时给出明确提示

注意事项 #

• 需保持Excel进程处于打开状态，否则定时任务会失效
• 可自行修改FromPath和ToPath为实际的源文件夹和目标文件夹路径
• 定时检查间隔（TimeValue("00:05:00")）可根据需求调整，比如改为TimeValue("00:01:00")即1分钟检查一次

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