Excel VBA自动发Outlook邮件遇服务器连接错误的重试方案问询

针对批量发送邮件时，Set OutMail = OutApp.CreateItem(0)偶尔出现的服务器连接错误，以下是带重试机制的代码实现，满足等待一分钟后重试、不跳过邮件也不终止程序的需求：

修改后的完整代码 #

Sub SendEmailsWithRetry()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim retryCount As Integer
    ' 可根据需求调整参数
    Const MAX_RETRIES As Integer = 3 ' 最大重试次数
    Const WAIT_SECONDS As Integer = 60 ' 每次等待秒数
    
    ' 仅初始化一次Outlook应用实例
    Set OutApp = CreateObject("Outlook.Application")
    
    retryCount = 0
RetryCreateMail:
    On Error GoTo ErrHandler
    ' 尝试创建邮件项
    Set OutMail = OutApp.CreateItem(0)
    
    ' 邮件内容组装与发送
    With OutMail
        .Display
        .To = Range("Array_emp_email")       
        .SentOnBehalfOfName = "mailbox@domain.com"
        .Subject = "mySubject"
        .HTMLBody = "mailBody" & Signature
        .Attachments.Add docPath & ".pdf"
        .Send
    End With
    
    ' 清理对象
    Set OutMail = Nothing
    Set OutApp = Nothing
    Exit Sub
    
ErrHandler:
    ' 匹配目标服务器连接错误
    If Err.Number = -2147467259 Or Err.Description Like "*can't contact the server*" Then
        retryCount = retryCount + 1
        If retryCount <= MAX_RETRIES Then
            ' 等待指定时长
            Application.Wait Now + TimeSerial(0, 0, WAIT_SECONDS)
            Err.Clear
            ' 回到创建邮件的步骤重试
            GoTo RetryCreateMail
        Else
            ' 重试耗尽后的处理
            MsgBox "已重试" & MAX_RETRIES & "次，仍无法创建邮件：" & Err.Description, vbCritical
            Set OutMail = Nothing
            Set OutApp = Nothing
            Err.Raise Err.Number
        End If
    Else
        ' 其他未预期错误的处理
        MsgBox "发生异常错误：" & Err.Description, vbCritical
        Set OutMail = Nothing
        Set OutApp = Nothing
        Err.Raise Err.Number
    End If
End Sub

关键说明 #

• Outlook实例复用：仅在开头创建一次OutApp，避免重复实例化导致的额外资源消耗和冲突
• 精准错误匹配：通过错误编号和描述双重判断，确保只对服务器连接错误进行重试
• 可控重试逻辑：设置最大重试次数，防止无限循环；等待使用Application.Wait，无需额外API声明，适配Office 365环境
• 错误保留机制：重试耗尽后仍抛出错误，便于排查根因，同时避免静默失败

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