Sending Multiple Attachments

[DarrylK]

Hi,

I am trying to send multiple attachments on an email.

I am using the following code to send a single attachment however I would like to send all the attachments located in Column C on a sheet named "ITEM INQUIRY LIST"

With OutMail
.To = Range("P8").Value
.CC = "Mickey.Mouse@Disney.com"
.Subject = "Encore Glass Samples are on their way to " & Range("R4").Value & " (" & Range("Q6").Value & ")"
.Attachments.Add Range("P30").Value
.Body = EmailBody
.Send
End With

Assistance would be greatly appreciated!

 

[Domenic]

If your range does not contain empty cells, then you could first define and assign the range to an object variable...

Dim rRecipients As Range
Dim LastRow As Long


With Worksheets("ITEM INQUIRY LIST")
    LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
    Set rRecipients = .Range("C1:C" & LastRow)
End With

And then you could assign the recipients as follows...

.Attachments.Add Join(application.Transpose(rRecipients), ";")

If your range can contain empty cells, first fill an array with the email addresses...

Dim aRecipients() As String
Dim rRecipients As Range
Dim rCell As Range
Dim LastRow As Long
Dim Cnt As Long


With Worksheets("ITEM INQUIRY LIST")
    LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
    Set rRecipients = .Range("C1:C" & LastRow)
End With


ReDim aRecipients(1 To LastRow)


Cnt = 0
For Each rCell In rRecipients
    If Len(rCell) > 0 Then
        Cnt = Cnt + 1
        aRecipients(Cnt) = rCell.Value
    End If
Next rCell


If Cnt = 0 Then
    MsgBox "No data found.", vbExclamation
    Exit Sub
End If


ReDim Preserve aRecipients(1 To Cnt)

Then assign them as follows...

.Attachments.Add Join(aRecipients, ";")

Hope this helps!