Sending multiple email using range with attachment in VBA

Question

This is the first time I am trying from Excel to send email using VBA code.

Here is my structure of my Excel. Sometimes the email list will have 1 - 20 or only 1 also

A (col) B          C         D        E     F              G
Sl.No  First Name To Email  CC Email Subj   File to Send   Message

Code:

Option Explicit

Sub SendMail()

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)

With ActiveSheet
Set rngTo = .Range("C2")
Set rngSubject = .Range("E2")
Set rngBody = .Range("G2")
Set rngAttach = .Range("F2")
End With

With objMail
    .To = rngTo.Value
    .Subject = rngSubject.Value
    .Body = rngBody.Value
    .Attachments.Add rngAttach.Value
    .Display

End With

Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub

Here is my code this was working perfectly fine but for single emails to send, but not for multiple email.

I am struggling here to find how to send for multiple email with attachment using the tested code.

Answer 1

Maybe Try this:

Option Explicit

Sub SendMail()

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 i As Integer

Set objOutlook = CreateObject("Outlook.Application")


For i = 2 To 21 ' Loop from 2 to 21


    With ActiveSheet
    Set rngTo = .Range("C" & i)
    Set rngSubject = .Range("E" & i)
    Set rngBody = .Range("G" & i)
    Set rngAttach = .Range("F" & i)
    End With

    Set objMail = objOutlook.CreateItem(0)

    With objMail
        .To = rngTo.Value
        .Subject = rngSubject.Value
        .HTMLBody = "<B><U>" & rngBody.Value & ":</B></U>"
        .Attachments.Add rngAttach.Value
        .Display

    End With

    Set objMail = Nothing

Next

Set objOutlook = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub

You can loop through the Range to generate 20 emails.

---

Update

• Added .HTMLBody instead of .Body to make text Bold And Underlined

• You can use more HTML commands to make certain portions of the Text Bold and More.

Answer 2

You need a loop for that. The below code will start with the second row and continue until it finds an empty row.

Option Explicit

Sub SendMail()
    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")

    Dim r As Long: For r = 2 To ActiveSheet.Range("C2").End(xlDown).Row
        With ActiveSheet
            Set rngTo = .Range("C" & r)
            Set rngSubject = .Range("E" & r)
            Set rngBody = .Range("G" & r)
            Set rngAttach = .Range("F" & r)
        End With

        Set objMail = objOutlook.CreateItem(0)
        With objMail
            .to = rngTo.Value
            .Subject = rngSubject.Value
            .Body = rngBody.Value
            .Attachments.Add rngAttach.Value
            .Display
            .Send ' If you want to send it without clicking
        End With
    Next
End Sub

Also note: These Set x = Nothing lines are superfluous, delete them because they just make the code less readable for humans. Regarding this issue you can also refer to this SO question: Is there a need to set Objects to Nothing inside VBA Functions

Update

Sorry this line has to be inside the loop, I updated the code:

Set objMail = objOutlook.CreateItem(0)

Answer 3

Try it this way.

Make a list in Sheets("Sheet1") with :

In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)

The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.

Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set sh = Sheets("Sheet1")

    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

        'Enter the path/file names in the C:Z column in each row
        Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)

            With OutMail
                .to = cell.Value
                .Subject = "Testfile"
                .Body = "Hi " & cell.Offset(0, -1).Value

                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell

                .Send  'Or use .Display
            End With

            Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

https://www.rondebruin.nl/win/s1/outlook/amail6.htm