Question

我有现有代码从我的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

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

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

Answer 3

此更新代码：

从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

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

3 个答案: