Excel VBA通过CDO发送Office 365邮件报错求助（错误码0x80040217）

出现0x80040217错误的核心原因是Office365的SMTP认证机制变更，加上原代码存在语法和逻辑问题，以下是具体解决步骤：

1. 优先改用Outlook对象模型（推荐方案） #

CDO原生不支持Office365现在要求的OAuth2认证，改用Outlook对象模型更稳定，无需手动配置SMTP参数：

Sub SendEmailsViaOutlook()
    Dim olApp As Object
    Dim olMail As Object
    Dim i As Integer
    
    On Error GoTo Error_Handling
    
    ' 初始化Outlook应用
    Set olApp = CreateObject("Outlook.Application")
    
    i = 2
    ' 遍历Data工作表的邮件列表
    While Sheets("Data").Cells(i, 1) <> ""
        Set olMail = olApp.CreateItem(0) ' 创建普通邮件
        
        With olMail
            .Subject = "Z-Reporti"
            .From = "gjhjj@forexapmle.com"
            .To = Sheets("Data").Cells(i, 4)
            .Body = "xcvjlxcv  ;lkjladsfgdafg "
            .Send ' 直接发送，替换为.Display可手动预览发送
        End With
        
        Set olMail = Nothing
        i = i + 1
    Wend
    
    Set olApp = Nothing
    MsgBox "邮件发送完成"
    
Error_Handling:
    If Err.Number <> 0 Then
        MsgBox "错误代码：" & Err.Number & vbCrLf & "错误描述：" & Err.Description
    End If
End Sub

2. 若坚持使用CDO的修正方案 #

2.1 解决认证问题 #

Office365默认禁用普通密码SMTP登录，需做以下配置（不推荐，存在安全风险）：

• 登录Office365管理员中心，找到目标账户，开启允许应用使用用户名和密码登录
• 若账户开启了两步验证，必须使用应用密码替代原账户密码，而非普通登录密码

2.2 修正原代码的语法与逻辑错误 #

原代码存在Wend位置错误、邮件对象重复使用的问题，修正后代码如下：

Sub SendEmailsViaCDO()
    Dim CDO_Mail As Object
    Dim CDO_Config As Object
    Dim SMTP_Config As Variant
    Dim strSubject As String
    Dim strFrom As String
    Dim strTo As String
    Dim strBody As String
    Dim i As Integer
    
    On Error GoTo Error_Handling
    
    ' 配置SMTP参数
    Set CDO_Config = CreateObject("CDO.Configuration")
    CDO_Config.Load -1
    Set SMTP_Config = CDO_Config.Fields
    
    With SMTP_Config
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.office365.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 587
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 10
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "gjhjj@forexapmle.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "你的应用密码/低权限账户密码"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Update
    End With
    
    i = 2
    While Sheets("Data").Cells(i, 1) <> ""
        ' 每次循环创建新的邮件对象，避免冲突
        Set CDO_Mail = CreateObject("CDO.Message")
        Set CDO_Mail.Configuration = CDO_Config
        
        strSubject = "Z-Reporti"
        strFrom = "gjhjj@forexapmle.com"
        strTo = Sheets("Data").Cells(i, 4)
        strBody = "xcvjlxcv  ;lkjladsfgdafg "
        
        With CDO_Mail
            .Subject = strSubject
            .From = strFrom
            .To = strTo
            .TextBody = strBody
            .Send
        End With
        
        Set CDO_Mail = Nothing
        i = i + 1
    Wend
    
    MsgBox "邮件发送完成"
    
Error_Handling:
    If Err.Description <> "" Then
        MsgBox "错误描述：" & Err.Description
    End If
    ' 清理对象释放资源
    Set CDO_Mail = Nothing
    Set CDO_Config = Nothing
    Set SMTP_Config = Nothing
End Sub

3. 额外检查项 #

• 确认smtp.office365.com端口587可正常访问，本地防火墙/杀毒软件未拦截SMTP请求
• 发送邮箱地址需与SMTP配置中的sendusername完全一致

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