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

Question

我已经有现有的代码可以从我Excel文件中的一个Sheet发送邮件——

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")不能帮助实现这一点。

请问有什么帮助吗？ 提前感谢！

- Thomas Varghese

---

B4 中是什么 - 文件路径吗？ - brettdj

循环遍历文件路径范围，并逐个添加每个路径。 - Rory

您可以多次使用.Attachments.Add来添加每个附件。每次都可以使用循环将其引用到不同的路径。 - izzymo

@brettdj 是的，B4有一个文件路径，我在B5、B6等地方也有多个路径。 - Thomas Varghese

@Rory，你能帮我解决一下这段代码吗？ - Thomas Varghese

@izzymo 你能帮我解决这段代码吗？ - Thomas Varghese

Answer 1

在循环中使用.Attachments.Add语句。类似下面的内容可能有效。

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

- Abhijeet Shukla

---

嗨，Abhijeet，有什么方法可以使这个动态化吗？ - Thomas Varghese

Answer 2

为使其具有动态性，您可以将 i 的上限设置为 B 列中的最后一行。

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

- izzymo

Answer 3

这段更新后的代码：

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

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
   

- brettdj