Excel VBA调用Outlook .Send触发O365错误80004005求解决方案

结论确认 #

Copilot的判断准确：该80004005错误（法语提示“无法识别一个或多个名称”）确实是Outlook近期安全更新引入的强制交互验证机制导致。微软目前未公开该变更的官方文档，但从批量用户反馈来看，这是Win11+O365环境下针对自动化邮件发送的安全限制——非用户手动触发的.Send操作会被拦截，必须经过显性交互（如打开邮件窗口）才能通过验证。

临时方案的局限性 #

• 替换.Send为.Display：需手动点击发送按钮，完全失去自动化能力，不适合批量场景。
• 前置.Display + DoEvents：虽能自动发送，但每封邮件都会弹出窗口，批量发件时严重影响效率，且可能被系统判定为异常操作。

隐蔽替代方案 #

方案1：使用CDO.Message直接通过SMTP发送（推荐） #

绕过Outlook客户端，直接与邮件服务器建立SMTP连接发送邮件，无弹窗、无交互要求，完全自动化。示例代码如下：

Option Explicit

Sub SendEmailViaCDO()
    Dim cdoMsg As Object
    Set cdoMsg = CreateObject("CDO.Message")
    
    ' 配置SMTP服务器参数（以Orange为例，需根据实际邮箱调整）
    With cdoMsg.Configuration.Fields
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.orange.fr"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 587 ' 或465（SSL）
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 ' 需身份验证
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "your-orange-email@orange.fr"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "your-email-password" ' 部分邮箱需用授权码
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True ' 启用SSL
        .Update
    End With
    
    ' 设置邮件内容
    With cdoMsg
        .To = "name1@orange.fr"
        .Subject = "Test"
        .TextBody = "Bonjour"
        .Send ' 无弹窗直接发送
    End With
    
    Set cdoMsg = Nothing
    MsgBox "邮件发送成功", vbInformation
End Sub

注意：需确保目标邮箱开启SMTP服务，部分邮箱（如Orange）需使用应用专用授权码替代登录密码。

方案2：将Excel添加到Outlook信任列表（企业环境适用） #

1. 打开Outlook，依次点击「文件」→「选项」→「信任中心」→「信任中心设置」→「程序访问」。
2. 在「允许访问Outlook数据文件的其他程序」中，添加Excel.exe的路径（通常为C:\Program Files\Microsoft Office\root\Office16\EXCEL.EXE）。
3. 重启Outlook和Excel后，原VBA代码可恢复无弹窗自动发送。

方案3：修改Outlook注册表信任设置（受控环境适用） #

通过注册表将Excel标记为信任的COM调用者，跳过交互验证：

1. 打开注册表编辑器（regedit.exe），定位到HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Outlook\Security。
2. 新建DWORD值PromptOOMSend，设置值为0。
3. 新建DWORD值AdminSecurityMode，设置值为0。

注意：该方法会降低Outlook安全防护等级，仅建议在内部受控环境中使用。

原问题复现代码 #

Option Explicit
    
Sub test()
 
    Dim olApp As Outlook.Application
    ' Tente de récupérer Outlook déjà ouvert
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    On Error GoTo 0
    
    ' Si Outlook n'est pas ouvert : le créer
    If olApp Is Nothing Then
        On Error Resume Next
        Set olApp = CreateObject("Outlook.Application")
        On Error GoTo 0
    End If

    Dim olMail As Outlook.MailItem
    Set olMail = olApp.CreateItem(olMailItem)
    With olMail
        .recipients.Add "name1@orange.fr"
        .Subject = "Test"
        .Body = "Bonjour"
        '.Display
        'DoEvents
        .Send
    End With

End Sub

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