如何在Excel VBA中确认邮件附件已正确添加并优化发送逻辑

我编写了一个Excel VBA脚本，通过邮件列表创建带独立附件的个性化邮件。原本需手动确认附件正确添加后发送，现在希望实现发送自动化，但运行脚本时发现，即使单元格生成的文件路径对应文件不存在，测试环境下邮件仍会发送。现有代码的If语句仅判断邮件对象的附件数量，而非验证文件是否存在并成功附加。我需要实现：附件添加失败的邮件仍能创建，但不发送，以便调试失败原因。

原脚本：

Sub emailMergeWithAttachments()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim ws As Worksheet
    Dim strBody As String
    Dim rowCount As Integer
    Dim i As Integer
    Dim testing As Boolean
    Dim mailsCreated As Integer
    Dim mailsSent As Integer
    
    
    mailsCreated = 0
    mailsSent = 0
    testing = True
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ws.Activate
    rowCount = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))
    
    For i = 2 To rowCount
        If ws.Cells(i, 4) Then
            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)
            
            strBody = "Hi " & ws.Cells(i, 1) & _
            ",<p>Please find attached last fortnights Performance Report." & _
            "<p>If you have any issues or questions please reach out via Email."
            
            On Error Resume Next
            With OutMail
                .To = ws.Cells(i, 3).Text
                .CC = ""
                .BCC = ""
                .Subject = "Individual Performance Report"
                .Display
                .HTMLBody = strBody & .HTMLBody
                .Attachments.Add ws.Cells(i, 5).Text
                If .Attachments.Count > 0 Then
                    .Send
                    mailsSent = mailsSent + 1
                End If
                mailsCreated = mailsCreated + 1
                    
            End With
            On Error GoTo 0
            
            Set OutMail = Nothing
            Set OutApp = Nothing
            If testing Then Exit For
        End If
    Next i
       
    MsgBox (mailsCreated & " emails Created" & vbNewLine & _
      mailsSent & " emails Sent")
    
End Sub

修改后的脚本 #

Sub emailMergeWithAttachments()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim ws As Worksheet
    Dim strBody As String
    Dim rowCount As Integer
    Dim i As Integer
    Dim testing As Boolean
    Dim mailsCreated As Integer
    Dim mailsSent As Integer
    Dim attachmentPath As String
    Dim attachSuccess As Boolean
    
    mailsCreated = 0
    mailsSent = 0
    testing = True
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    rowCount = WorksheetFunction.CountA(ws.Range("A1", ws.Range("A1").End(xlDown)))
    
    For i = 2 To rowCount
        If ws.Cells(i, 4) Then
            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)
            attachmentPath = ws.Cells(i, 5).Text
            attachSuccess = False
            
            strBody = "Hi " & ws.Cells(i, 1) & _
            ",<p>Please find attached last fortnights Performance Report." & _
            "<p>If you have any issues or questions please reach out via Email."
            
            With OutMail
                .To = ws.Cells(i, 3).Text
                .CC = ""
                .BCC = ""
                .Subject = "Individual Performance Report"
                .HTMLBody = strBody & .HTMLBody
                
                ' 先检查文件是否存在
                If Dir(attachmentPath) <> "" Then
                    On Error Resume Next
                    .Attachments.Add attachmentPath
                    ' 检查附件是否成功添加
                    If Err.Number = 0 Then
                        attachSuccess = True
                    End If
                    On Error GoTo 0
                End If
                
                ' 仅当附件成功添加时发送邮件
                If attachSuccess Then
                    .Send
                    mailsSent = mailsSent + 1
                Else
                    ' 附件添加失败，仅创建邮件不发送
                    .Display
                End If
                mailsCreated = mailsCreated + 1
            End With
            
            Set OutMail = Nothing
            Set OutApp = Nothing
            If testing Then Exit For
        End If
    Next i
       
    MsgBox (mailsCreated & " emails Created" & vbNewLine & _
      mailsSent & " emails Sent")
    
End Sub

关键修改说明 #

• 添加文件存在性验证：使用Dir(attachmentPath) <> ""预先检查单元格中的路径是否对应有效文件
• 细化附件添加错误捕获：在添加附件时临时启用错误处理，通过Err.Number判断是否添加成功
• 调整发送逻辑：只有文件存在且附件添加成功时才调用.Send，失败时仅调用.Display保留邮件草稿用于调试
• 优化代码严谨性：使用ws.Range替代未限定的Range，避免激活工作表带来的潜在问题

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