Sending multiple attachments from excel sheet with VBA

问题

I have the existing code to send a mail from a Sheet in my Excel file -

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

However, I want to include a number of attachments, and hence the Set rngAttach = .Range("B4") does not help to do this.

Any help on this? Thanks in advance!

回答1:

Enclose your .Attachments.Add statement in loop. Something like below might work

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

回答2:

To make it Dynamic you can set the upper limit of i to the last row in Column B

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

回答3:

This updated code:

Looks for file names from B4
Uses Dir to ensure the attached files actually exist at the specified path

Tidies up the worksheet code (Activate is unnecessary)

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

来源：https://stackoverflow.com/questions/29251868/sending-multiple-attachments-from-excel-sheet-with-vba

标签

vba

excel

outlook