Outlook VBA单Sub实现附件保存后打开Excel文件及延时问题

我有一个由Outlook规则触发的Public Sub Save_and_Open，这个子程序能正常保存邮件附件，但在同一个Sub里添加延时（比如Application.Wait）和打开Excel文件（比如Workbooks.Open）的代码后就无法正常运行。我能写出独立运行的打开文件子程序，但调用它会报错，现在想把所有功能整合到同一个Sub里。

现有Save_and_Open代码 #

Public Sub Save_and_Open (itm As Outlook.MailItem)

Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim FSO As Object
Dim oldName
Dim file As String
Dim DateFormat As String
Dim newName As String
Dim enviro As String

saveFolder = "S:\Save\"

Set FSO = CreateObject("Scripting.FileSystemObject")

On Error Resume Next
    For Each objAtt In itm.Attachments

'判断文件后缀的字符长度
        Select Case Right(LCase(objAtt.FileName), 4)

'根据附件后缀重命名保存
            Case ".csv": objAtt.SaveAsFile saveFolder & "NAME_CSV.csv"
            Case ".txt": objAtt.SaveAsFile saveFolder & "NAME_TXT.txt"
            Case "xlsx": objAtt.SaveAsFile saveFolder & "NAME_XLSX.xlsx"
            Case Else
        End Select
        Set objAtt = Nothing
    Next
   
 Set FSO = Nothing

'曾尝试多种延时方式，确保文件保存完成后再打开
'Application.Wait(Now + #0:00:015#)

'也尝试过直接打开文件，但无法运行
'Workbooks.Open Filename:= _
    "S:\FileName.xlsx"

End Sub

可独立运行的RevisionFile代码 #

Sub RevisionFile(itm As Outlook.MailItem)

Dim FileName As String
Dim RetVal
Dim fs
Dim currenttime As Date

currenttime = Now
'死循环等待20秒
Do Until currenttime + TimeValue("00:00:20") <= Now
Loop

FileName = "S:\Revision.xlsm"

Set fs = CreateObject("Scripting.FileSystemObject")
    If (fs.FileExists(FileName)) Then
    '通过Shell命令打开文件
    Shell "cmd.exe /c Start ""Tiff"" """ & FileName & """"

 Else
    MsgBox ("文件未找到")

End If

End Sub

核心问题分析 #

Outlook规则触发的VBA子程序运行在Outlook主线程中，直接用Application.Wait或死循环会阻塞Outlook进程，导致文件操作异常；直接调用Workbooks.Open可能因为未正确初始化Excel实例、文件未完全写入或权限问题报错。

整合后的完整代码 #

' 放在模块顶部的Sleep函数声明
#If VBA7 Then
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
    Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Public Sub Save_and_Open(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    Dim FSO As Object
    Dim targetExcelPath As String
    Dim waitStartTime As Date
    
    saveFolder = "S:\Save\"
    targetExcelPath = "S:\Revision.xlsm" ' 指定要打开的Excel文件路径
    
    ' 1. 保存邮件附件
    Set FSO = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    For Each objAtt In itm.Attachments
        Select Case Right(LCase(objAtt.FileName), 4)
            Case ".csv": objAtt.SaveAsFile saveFolder & "NAME_CSV.csv"
            Case ".txt": objAtt.SaveAsFile saveFolder & "NAME_TXT.txt"
            Case "xlsx": objAtt.SaveAsFile saveFolder & "NAME_XLSX.xlsx"
            Case Else
        End Select
        Set objAtt = Nothing
    Next
    On Error GoTo 0 ' 恢复正常错误捕获
    Set FSO = Nothing
    
    ' 2. 等待文件写入完成（避免阻塞Outlook）
    waitStartTime = Now
    Do While True
        ' 检查文件是否存在且可读写（确认写入完成）
        If FSO.FileExists(targetExcelPath) Then
            Dim testFileNum As Integer
            testFileNum = FreeFile()
            On Error Resume Next
            Open targetExcelPath For Input Lock Read Write As #testFileNum
            Close #testFileNum
            If Err.Number = 0 Then Exit Do ' 文件可访问，说明写入完成
            On Error GoTo 0
        End If
        
        ' 超时保护，防止无限等待
        If Now > waitStartTime + TimeValue("00:00:30") Then
            MsgBox "等待文件超时，无法打开目标Excel"
            Exit Sub
        End If
        
        DoEvents ' 释放CPU资源，让Outlook正常响应
        Sleep 500 ' 等待500毫秒，减少循环频率
    Loop
    
    ' 3. 安全打开Excel文件
    Dim excelApp As Object
    On Error Resume Next
    ' 优先获取已运行的Excel实例
    Set excelApp = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        ' 没有运行的Excel则新建实例
        Set excelApp = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
    
    excelApp.Visible = True ' 显示Excel窗口
    excelApp.Workbooks.Open targetExcelPath
    
    ' 释放对象
    Set excelApp = Nothing
End Sub

关键优化点 #

• 非阻塞延时：用DoEvents+Sleep替代死循环/Application.Wait，既等待文件写入，又不阻塞Outlook进程。
• 文件有效性验证：通过尝试以独占方式打开文件，确保文件真正写入完成，避免因磁盘缓存导致的文件未就绪问题。
• Excel实例管理：优先复用已运行的Excel实例，减少资源消耗；设置Visible=True确保能看到打开的文件。
• 错误处理优化：局部使用On Error Resume Next，避免全局错误捕获隐藏问题；添加超时逻辑防止程序无限等待。

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