使用 VBA 从 excel 工作表发送多个附件答案

【问题标题】：Sending multiple attachments from excel sheet with VBA使用 VBA 从 excel 工作表发送多个附件
【发布时间】：2015-05-28 21:35:35
【问题描述】：

我有从 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") 无济于事。

对此有任何帮助吗？提前致谢！

【问题讨论】：

B4 中有什么 - 文件路径？
循环遍历文件路径范围并依次添加每个路径。
您可以多次使用.Attachments.Add来添加每个附件。每次都可能使用循环将其引用到不同的路径。
@brettdj 是的，B4 有一个文件路径，我在 B5、B6 中也有多个路径，等等
@Rory 你能帮我写代码吗？

标签： vba email excel outlook

【解决方案1】：

此更新代码：

从B4 中查找文件名
使用Dir确保附件确实存在于指定路径

整理工作表代码（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

【讨论】：

【解决方案2】：

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

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

【讨论】：

【解决方案3】：

在循环中包含您的 .Attachments.Add 语句。像下面这样的东西可能会起作用

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

【讨论】：

嗨，Abhijeet 有什么办法可以让这个动态化？？