如何在VBA中设置等待Outlook完成邮件操作后再执行后续步骤？

问题根源 #

你遇到的问题是因为Outlook的UI操作与Excel VBA执行是异步的，.Display True在部分场景下无法确保所有邮件编辑操作完成，固定等待时长也无法适配不同系统的处理速度，导致Excel后续流程提前执行甚至崩溃。

可靠解决方案：监听Outlook邮件关闭事件 #

通过绑定Outlook邮件项的Close事件，让Excel代码等待直到用户关闭邮件窗口，确保所有邮件创建、附件添加、表格插入操作都完成后，再继续执行后续流程。

步骤1：创建自定义类模块 #

1. 在VBA编辑器中，右键点击项目 → 插入 → 类模块
2. 将类模块命名为clsOutlookMail（在属性窗口修改名称）
3. 粘贴以下代码到类模块：

Option Explicit

Public WithEvents OutMail As Outlook.MailItem
Public MailClosed As Boolean

Private Sub OutMail_Close(Cancel As Boolean)
    MailClosed = True
End Sub

步骤2：修改Mail_send子程序 #

替换原有的Mail_send代码为以下版本，优化了冗余操作并添加事件监听：

Option Explicit
    
Sub Mail_send()
    
    If MsgBox("Do you want to send out the report?", vbYesNo) = vbNo Then
        GoTo skip
    End If
    
    Dim OutApp As Object
    Dim objMail As clsOutlookMail
    Dim rg1 As Range
    Dim str1 As String
    Dim emailRng1 As Range, cl1 As Range
    Dim sTo1 As String
    Dim emailRng2 As Range, cl2 As Range
    Dim sTo2 As String
    Dim MaxD As Date
    
    ' 获取最大日期
    MaxD = GetMaxDate(Sheets("Raw data").Columns(33))
        
    ' 读取收件人列表（To和CC）
    With Sheets("Mail loops and contact persons")
        Set emailRng1 = .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
        For Each cl1 In emailRng1
            sTo1 = sTo1 & ";" & cl1.Value
        Next
        sTo1 = Mid(sTo1, 2)
        
        Set emailRng2 = .Range("C2:C" & .Cells(.Rows.Count, "C").End(xlUp).Row)
        For Each cl2 In emailRng2
            sTo2 = sTo2 & ";" & cl2.Value
        Next
        sTo2 = Mid(sTo2, 2)
    End With
       
    ' 定义要插入邮件的表格区域
    With Sheets("Table")
        Set rg1 = .Range(.Cells(3, 2), .Cells(7, 8))
    End With
    
    ' 初始化Outlook和自定义事件类
    Set OutApp = CreateObject("Outlook.Application")
    Set objMail = New clsOutlookMail
          
    ' 构建邮件HTML内容
    str1 = "<BODY style='font-size:12pt; font-family:Calibri'>" & _
           "Dear all,<br><br> Please find the productivity report for the last working day."
        
    On Error Resume Next
    Set objMail.OutMail = OutApp.CreateItem(0)
    With objMail.OutMail
        .To = sTo1
        .CC = sTo2
        .Subject = "Productivity Report" & " " & Format(MaxD - 1, "yyyy-mm-dd")
        .Attachments.Add ActiveWorkbook.FullName
        .HTMLBody = str1 & RangetoHTML(rg1) & .HTMLBody
        .Display ' 显示邮件窗口
    End With
    On Error GoTo 0
    
    ' 等待用户关闭邮件窗口
    Do While Not objMail.MailClosed
        DoEvents ' 保持Excel响应，避免假死
    Loop
    
skip:
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    ' 清理对象，释放内存
    Set objMail = Nothing
    Set OutApp = Nothing
End Sub

额外优化说明 #

• 移除了原代码中重复的.Display调用，简化流程
• 使用With语句避免不必要的工作表激活/选择，提升代码稳定性
• 修复了HTML样式中的语法错误（原代码缺少分号分隔样式属性）
• 添加对象清理步骤，防止内存泄漏

替代方案：自动发送邮件（无需用户干预） #

如果不需要用户手动编辑邮件，可以直接调用.Send方法，代码会同步等待邮件发送完成后再继续执行后续流程：

' 替换原代码中邮件显示和等待的部分
With objMail.OutMail
    .To = sTo1
    .CC = sTo2
    .Subject = "Productivity Report" & " " & Format(MaxD - 1, "yyyy-mm-dd")
    .Attachments.Add ActiveWorkbook.FullName
    .HTMLBody = str1 & RangetoHTML(rg1) & .HTMLBody
    .Send ' 直接发送，代码会等待发送完成
End With

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