Excel VBA调用Outlook发送多附件批量邮件的代码修改咨询

要实现单邮件添加2个附件的需求，只需要调整表格结构+补充少量代码即可，Outlook的Attachments.Add方法支持多次调用添加多个附件：

• 首先调整Sheet3的列布局：在原有D列（第一个附件路径）右侧新增E列，用来存放第二个附件的完整本地绝对路径
• 在原有附件添加逻辑后，新增针对E列的非空判断和附件添加代码

修改后的完整代码如下：

Sub Send_Multiple_Email()
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Sheets("Sheet3")
    Dim oa As Object
    Dim msg As Object
    
    Set oa = CreateObject("outlook.Application")
    Dim i As Integer
    Dim last_row As Integer
    
    last_row = Application.WorksheetFunction.CountA(sh.Range("A:A"))
    
    For i = 2 To last_row
        Set msg = oa.createitem(0)
    
        msg.to = sh.Range("A" & i).Value
        msg.Subject = sh.Range("B" & i).Value
        msg.body = sh.Range("c" & i).Value
    
        ' 添加第一个附件（D列）
        If sh.Range("D" & i).Value <> "" Then
            msg.attachments.Add sh.Range("D" & i).Value
        End If
        ' 新增：添加第二个附件（E列）
        If sh.Range("E" & i).Value <> "" Then
            msg.attachments.Add sh.Range("E" & i).Value
        End If
    
        ' 若不需要预览直接发送，可将msg.display替换为msg.send
        msg.display
     
     Next i
      
     MsgBox "mails sent"
     
End Sub

注意事项 #

• 所有附件都需要填写完整的本地绝对路径，例如C:\Users\XXX\Desktop\合同.pdf，仅填写文件名会导致调用失败
• 不需要添加第二个附件的收件人，对应E列留空即可，不会触发报错
• 如果后续需要添加更多附件，只要新增对应列，仿照上述逻辑添加判断和附件添加代码即可

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