使用VBA从Excel表格发送多个附件

我有现有的代码发送邮件从我的Excel文件中的工作表 –

Sub CreateMail() Dim objOutlook As Object Dim objMail As Object Dim rngTo As Range Dim rngSubject As Range Dim rngBody As Range Dim rngAttach As Range Set objOutlook = CreateObject("Outlook.Application") Set objMail = objOutlook.CreateItem(0) Application.ScreenUpdating = False Worksheets("Mail List").Activate With ActiveSheet Set rngTo = .Range("B1") Set rngSubject = .Range("B2") Set rngBody = .Range("B3") Set rngAttach = .Range("B4") End With With objMail .To = rngTo.Value .Subject = rngSubject.Value .body = rngBody.Value .Attachments.Add rngAttach.Value .display 'Instead of .Display, you can use .Send to send the email _ or .Save to save a copy in the drafts folder End With Set objOutlook = Nothing Set objMail = Nothing Set rngTo = Nothing Set rngSubject = Nothing Set rngBody = Nothing Set rngAttach = Nothing End Sub 

但是，我想包含一些附件，因此Set rngAttach = .Range("B4")不会帮助您做到这一点。

任何帮助吗？ 提前致谢！

Answer 1

将循环中的.Attachments.Add语句括起来。 像下面的东西可能会工作

  For i = 4 To 6 .Attachments.Add Range("B" & i).Value Next i 

Answer 2

要使其成为dynamic，您可以将i的上限设置为B列中的最后一行

 For i = 4 To Range("B" & rows.count).end(xlUp).row .Attachments.Add Range("B" & i).Value Next i 

Answer 3

这个更新的代码：

1. 从B4查找文件名
2. 使用Dir确保附加的文件实际存在于指定的path中

3. 整理工作表代码（ Activate是不必要的）

    Sub CreateMail() Dim objOutlook As Object Dim objMail As Object Dim rngTo As Range Dim rngSubject As Range Dim rngBody As Range Dim rngAttach As Range Dim rng2 As Range Dim ws As Worksheet Set objOutlook = CreateObject("Outlook.Application") Set objMail = objOutlook.CreateItem(0) Application.ScreenUpdating = False Set ws = Worksheets("Mail List") With ws Set rngTo = .Range("B1") Set rngSubject = .Range("B2") Set rngBody = .Range("B3") Set rngAttach = ws.Range(ws.[b4], ws.Cells(Rows.Count, "B").End(xlUp)) End With With objMail .To = rngTo.Value .Subject = rngSubject.Value .body = rngBody.Value For Each rng1 In rngAttach.Cells If Len(Dir(rng1)) > 0 Then .Attachments.Add rng1.Value Next .display 'Instead of .Display, you can use .Send to send the email _ or .Save to save a copy in the drafts folder End With Set objOutlook = Nothing Set objMail = Nothing Set rngTo = Nothing Set rngSubject = Nothing Set rngBody = Nothing Set rngAttach = Nothing End Sub