Excel VBA批量发送邮件异常：无法添加附件且邮件未发送

原代码存在的问题 #

• 循环内重复创建Outlook实例，既浪费资源也容易触发程序异常
• 附件仅使用单元格值，若不是完整文件路径，Outlook无法定位到文件
• .Display和.Send同时调用会产生冲突，弹窗会中断自动发送流程
• Cells未指定工作表，默认指向当前激活表，数据易出错
• 无错误处理，遇到无效邮箱、缺失附件时会直接终止运行

修正后的代码 #

Sub Sendemail()
    Dim olApp As Outlook.Application
    Dim olMail As Outlook.MailItem
    Dim lastrow As Long
    Dim i As Long
    Dim attachPath As String
    
    ' 只初始化一次Outlook实例
    Set olApp = New Outlook.Application
    
    lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    
    For i = 2 To lastrow
        On Error Resume Next ' 开启错误处理
        Set olMail = olApp.CreateItem(olMailItem)
        
        attachPath = Sheet1.Cells(i, 4).Value
        ' 校验附件路径是否有效
        If Dir(attachPath) = "" Then
            MsgBox "第" & i & "行附件不存在：" & attachPath, vbExclamation
            GoTo NextMail
        End If
        
        With olMail
            .To = Sheet1.Cells(i, 1).Value
            .Subject = Sheet1.Cells(i, 2).Value
            .Body = Sheet1.Cells(i, 3).Text
            .Attachments.Add attachPath
            .Send ' 直接发送，若需预览可替换为.Display并注释此行
        End With
        
NextMail:
        Set olMail = Nothing
        On Error GoTo 0 ' 关闭错误处理
    Next i
    
    ' 最后释放Outlook资源
    Set olApp = Nothing
    MsgBox "邮件批量发送完成", vbInformation
End Sub

关键改动说明 #

1. Outlook实例复用：将Set olApp = New Outlook.Application移至循环外，避免重复创建实例，提升运行稳定性
2. 明确工作表引用：所有Cells前加上Sheet1.，确保读取指定工作表的数据
3. 附件路径校验：用Dir()函数检查文件是否存在，避免因附件缺失导致发送失败
4. 错误处理机制：加入On Error Resume Next捕获异常，遇到错误时跳过当前邮件，继续发送后续邮件
5. 移除冲突指令：删除.Display，确保邮件自动发送；若需要手动预览邮件，可保留.Display并注释.Send

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