Excel VBA批量发送Outlook邮件触发OLE动作错误问题求助

你遇到的报错是因为Outlook COM对象未被正确释放，导致进程后台残留，二次运行时Excel调用OLE接口出现冲突。具体原因包括：

1. 代码运行结束后没有主动释放Outlook.Application和MailItem对象，Excel一直持有Outlook进程的引用，导致进程无法正常退出
2. 每次运行都强制新建Outlook实例，进一步加剧进程残留问题
3. 冗余逻辑和隐式转换可能增加OLE交互出错概率

如果已在VBA编辑器中提前引用「Microsoft Outlook xx.x Object Library」，使用以下代码：

Option Explicit
Sub SendBatchReminderEmails()
    Dim A As Outlook.Application
    Dim email As Outlook.MailItem
    Dim direc As String
    Dim body As String
    Dim i As Long
    
    ' 优先复用已运行的Outlook实例，避免重复创建
    On Error Resume Next
    Set A = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Err.Clear
        Set A = New Outlook.Application
    End If
    On Error GoTo ErrorHandle
    
    For i = 2 To ActiveSheet.Cells(Rows.Count, 16).End(xlUp).Row
        direc = Worksheets("NewSheet").Cells(i, 16).Value
        If direc <> "0" Then
            Set email = A.CreateItem(olMailItem)
            With email
                .To = direc
                .Subject = "Notification Test"
                body = Worksheets("NewSheet").Cells(i, 14).Value
                .HTMLBody = "<HTML><BODY style=font-size:11pt;font-family:Calibri>This is a notification reminder to let you know that you have <b>" & body & "</b> open contact(s) that you must Update</BODY><br><br>Best Regards, <br> Anonymous </br></HTML>"
                ' 无需预览邮件可直接删除下一行，减少OLE交互
                .Display
                .Send
            End With
            ' 单次发送完成立即释放当前邮件对象
            Set email = Nothing
        End If
    Next i

Cleanup:
    ' 统一释放所有COM对象，切断进程引用
    Set email = Nothing
    Set A = Nothing
    Exit Sub

ErrorHandle:
    MsgBox "运行错误：" & Err.Description, vbExclamation
    GoTo Cleanup
End Sub

如果未提前引用Outlook对象库，使用迟绑定版本即可：

Option Explicit
Sub SendBatchReminderEmails()
    Dim A As Object
    Dim email As Object
    Dim direc As String
    Dim body As String
    Dim i As Long
    
    On Error Resume Next
    Set A = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Err.Clear
        Set A = CreateObject("Outlook.Application")
    End If
    On Error GoTo ErrorHandle
    
    For i = 2 To ActiveSheet.Cells(Rows.Count, 16).End(xlUp).Row
        direc = Worksheets("NewSheet").Cells(i, 16).Value
        If direc <> "0" Then
            Set email = A.CreateItem(0)
            With email
                .To = direc
                .Subject = "Notification Test"
                body = Worksheets("NewSheet").Cells(i, 14).Value
                .HTMLBody = "<HTML><BODY style=font-size:11pt;font-family:Calibri>This is a notification reminder to let you know that you have <b>" & body & "</b> open contact(s) that you must Update</BODY><br><br>Best Regards, <br> Anonymous </br></HTML>"
                ' 无需预览邮件可直接删除下一行
                .Display
                .Send
            End With
            Set email = Nothing
        End If
    Next i

Cleanup:
    Set email = Nothing
    Set A = Nothing
    Exit Sub

ErrorHandle:
    MsgBox "运行错误：" & Err.Description, vbExclamation
    GoTo Cleanup
End Sub

• 实例复用：优先调用已运行的Outlook进程，避免每次运行都新建实例，降低进程残留概率
• 主动释放对象：单次邮件发送完成就释放当前邮件对象，程序结束前统一释放所有Outlook相关COM对象，彻底切断Excel对Outlook进程的引用，不会残留后台进程
• 错误兜底：新增错误捕获逻辑，就算运行过程中出现报错，也会优先执行对象释放步骤，不会出现OLE锁死的情况
• 冗余逻辑清理：移除重复的变量赋值语句，补全单元格取值的显式声明，避免隐式转换出错
• 可选优化：不需要预览邮件的情况下直接删除.Display语句，可大幅提升发送速度，同时减少OLE交互等待时间

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