Excel 2007 VBA调用Outlook 2007发送提醒邮件未发送问题

使用Excel 2007 VBA编写代码调用Outlook 2007发送提醒邮件时，邮件能在Outlook中显示，但无法完成发送。原始代码如下：

Sub send_mail()
    Dim OutApp As Object
    Dim outmail As Object
    Dim mail_list As Range
    Dim cell As Range
    
    Application.ScreenUpdating = False
    
    Set OutApp = CreateObject("Outlook.Application")
    On Error GoTo error_exit
    
    Set mail_list = Range(Range("D3"), Range("D3").End(xlDown))
    
    For Each cell In mail_list
        Set outmail = OutApp.createitem(0)
        On Error Resume Next
        With outmail
            .to = cell.Value
            .Subject = "Reminder"
            .body = "Postovana " & Cells(cell.Row, "C").Value & "," & vbNewLine & vbNewLine & _
            "Ovo je generisana poruka. Molim Vas da se javite na pregled." & vbNewLine & vbNewLine & _
            "Srdacan pozdrav" & vbNewLine & _
            "Dr"
            .send
        End With
        On Error GoTo 0
        Set outmail = Nothing
        
    Next cell
    
    error_exit:
    Set OutApp = Nothing
    
    Application.ScreenUpdating = True
    
End Sub

常见问题与修复方案 #

• Outlook安全拦截：Outlook 2007默认会阻止自动化程序发送邮件，若未手动确认授权，代码会卡在发送步骤。可通过以下方式解决：

  • 安装Outlook Redemption插件绕过安全限制；
  • 调整Outlook信任中心设置：文件>选项>信任中心>信任中心设置>程序访问，勾选“从不提醒我可疑活动”（注意：此操作降低安全防护，谨慎使用）；
  • 改用早期绑定：打开VBA编辑器，依次点击工具>引用，勾选「Microsoft Outlook 12.0 Object Library」，然后修改代码中的变量声明：

    Dim OutApp As Outlook.Application
    Dim outmail As Outlook.MailItem
    

• 错误捕获掩盖问题：代码中的On Error Resume Next会隐藏发送时的具体错误（比如收件人格式无效、邮箱未登录等）。建议暂时注释掉该行，运行代码查看错误提示，定位具体问题后再处理。

• Outlook未正常登录：确保Outlook已打开并登录目标邮箱账户，代码运行时Outlook需处于正常运行状态（后期绑定CreateObject会启动Outlook，但账户未自动登录时也会导致发送失败）。

• 收件人范围与有效性问题：原代码用End(xlDown)获取收件人范围，若D列中间有空行，会提前终止范围选取，甚至选中无效单元格。可替换为更可靠的范围获取方式：

  Set mail_list = Range("D3:D" & Cells(Rows.Count, "D").End(xlUp).Row)
  

  同时在循环中添加空值判断，跳过空单元格：

  If Trim(cell.Value) <> "" Then
      ' 邮件发送逻辑
  End If
  

修复后的完整代码示例 #

Sub send_mail()
    ' 启用早期绑定需先引用Microsoft Outlook 12.0 Object Library
    Dim OutApp As Outlook.Application
    Dim outmail As Outlook.MailItem
    Dim mail_list As Range
    Dim cell As Range
    
    Application.ScreenUpdating = False
    
    ' 检测并启动Outlook
    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set OutApp = New Outlook.Application
    End If
    On Error GoTo error_exit
    
    ' 可靠获取收件人范围
    Set mail_list = Range("D3:D" & Cells(Rows.Count, "D").End(xlUp).Row)
    
    For Each cell In mail_list
        If Trim(cell.Value) <> "" Then ' 跳过空单元格
            Set outmail = OutApp.CreateItem(olMailItem)
            With outmail
                .To = cell.Value
                .Subject = "Reminder"
                .Body = "Postovana " & Cells(cell.Row, "C").Value & "," & vbNewLine & vbNewLine & _
                "Ovo je generisana poruka. Molim Vas da se javite na pregled." & vbNewLine & vbNewLine & _
                "Srdacan pozdrav" & vbNewLine & _
                "Dr"
                .Send
            End With
            Set outmail = Nothing
        End If
    Next cell
    
error_exit:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
    ' 错误提示
    If Err.Number <> 0 Then
        MsgBox "发送失败，错误信息：" & Err.Description, vbExclamation
    End If
End Sub

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