如何用Application.OnTime实现VBA代码每日自动运行？代码次日无法启动

核心问题 #

• Outlook重启后，Application.OnTime注册的定时任务会被清空，导致次日无法自动触发宏。
• 当前代码缺少Outlook启动时初始化定时任务的逻辑。
• 遍历文件夹所有邮件会重复保存附件，效率极低。

修复后的完整代码 #

步骤1：在ThisOutlookSession中添加启动/退出事件 #

Private Sub Application_Startup()
    ' Outlook启动时初始化任务：当前在时段内则立即启动循环，否则设置次日8点触发
    If Time >= TimeValue("08:00:00") And Time <= TimeValue("10:30:00") Then
        AutoRefresh
    Else
        Application.OnTime TimeValue("08:00:00"), "Save_Attachment_GFI"
    End If
End Sub

Private Sub Application_Quit()
    ' 退出时取消定时任务，避免报错
    CancelAutoRefresh
End Sub

步骤2：修改定时与邮件处理宏 #

' 全局变量存储下一次任务时间，用于取消任务
Dim nextRunTime As Date

Sub AutoRefresh()
    nextRunTime = Now + TimeValue("00:02:30")
    Application.OnTime nextRunTime, "Save_Attachment_GFI"
End Sub

Sub Save_Attachment_GFI()
    Dim ONameSpace As Outlook.Namespace
    Dim Fol As Outlook.MAPIFolder
    Dim latestMail As Outlook.MailItem
    Dim Atmt As Outlook.Attachment
    Dim savePath As String
    
    ' 注意保存路径末尾必须加反斜杠
    savePath = "C:\XXX\"
    
    ' 使用当前Outlook实例，无需新建
    Set ONameSpace = Application.GetNamespace("MAPI")
    Set Fol = ONameSpace.GetDefaultFolder(olFolderInbox)
    Set Fol = Fol.Folders("FFA")
    Set Fol = Fol.Folders("FFA GFI")
    
    ' 按接收时间降序排序，取最新邮件
    Fol.Items.Sort "[ReceivedTime]", olDescending
    Set latestMail = Fol.Items(1)
    
    ' 跳过已处理的已读邮件
    If Not latestMail.UnRead Then GoTo Cleanup
    
    ' 保存附件（跳过已存在的文件）
    For Each Atmt In latestMail.Attachments
        If Dir(savePath & Atmt.Filename) = "" Then
            Atmt.SaveAsFile savePath & Atmt.Filename
        End If
    Next
    
    ' 标记邮件为已读，避免重复处理
    latestMail.UnRead = False
    latestMail.Save
    
    ' 循环定时：时段内继续，否则设置次日8点触发
    If Time >= TimeValue("08:00:00") And Time <= TimeValue("10:30:00") Then
        AutoRefresh
    Else
        Application.OnTime TimeValue("08:00:00"), "Save_Attachment_GFI"
    End If

Cleanup:
    ' 释放内存
    Set latestMail = Nothing
    Set Fol = Nothing
    Set ONameSpace = Nothing
    Set Atmt = Nothing
End Sub

' 取消定时任务的辅助宏
Sub CancelAutoRefresh()
    On Error Resume Next
    Application.OnTime nextRunTime, "Save_Attachment_GFI", , False
End Sub

关键优化说明 #

• 启动自动初始化：通过Application_Startup事件，每次Outlook启动时自动对接任务，彻底解决次日无法启动的问题。
• 避免重复处理：只处理最新的未读邮件，标记已读防止重复保存附件。
• 稳定的实例调用：使用当前Outlook实例而非新建，减少异常风险。
• 时段外自动预约：超出08:00-10:30时，自动设置次日8点的触发任务，无需手动干预。

内容的提问来源于stack exchange，提问作者André