CODEWITHSUNDEEP
excelvba
Alex Sirbu
Alex Sirbu

Reputation: 37

Setting up a mass distribution email list from Excel

This should be straight-forward but I somehow can't get it right. I am trying to set-up an automatic email blast from Excel. I have followed step by step the instructions from other posts here, with no success. This is a dummy example I've created, for the sake of simplicity.

enter image description here I would like to:

My current code sends the email only to the first person in the list. I've used my personal email address for testing purposes. I wonder if sending the emails to the same address could be the issue. If anybody can provide some guidance, would be much appreciated!

Sub SendMail()

Dim EmailSent, EmailFailed, i As Integer
Dim StatusSent, StatusFailed As String

Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")

Dim olMail As Outlook.MailItem
Set olMail = olApp.CreateItem(olMailItem)


EmailSent = 0
EmailFailed = 0
StatusFailed = "failed"
StatusSent = "sent"
i = 1

Do
DoEvents

    With olMail
        .To = Cells(i, 1).Value
        .Subject = "test"
        .CC = ""
        .BCC = ""
        .Importance = olImportanceHigh
        .BodyFormat = olFormatHTML

        .HTMLBody = Cells(i, 2).Value

        If Cells(i, 3) = 1 Then
            .HTMLBody = VBA.Replace(olMail.HTMLBody, "replace_me", Cells(i, 4))
        Else
            .HTMLBody = VBA.Replace(olMail.HTMLBody, "replace_me", Cells(i, 5))
        End If

       .send

    End With

    On Error Resume Next
    olMail.send

    If Err Then
        EmailFailed = EmailFailed + 1
        ActiveSheet.Cells(i, 6).Value = StatusFailed    'change status from pending to failed
    Else
        EmailSent = EmailSent + 1
        ActiveSheet.Cells(i, 6).Value = StatusSent  'change status from pending to sent
    End If

    i = i + 1
Loop Until i = Range(Range("A1"), Range("A1").End(xlDown)).Count

If EmailSent = 0 Then
    MsgBox Prompt:="Emails could not be sent"
Else
    MsgBox Prompt:="Sent emails: " & EmailSent & vbNewLine _
    & "Failed emails: " & EmailFailed
End If

On Error GoTo 0
Set olApp = Nothing
Set olMail = Nothing

End Sub

Upvotes: 2

Views: 124

Answers (1)

dwirony
dwirony

Reputation: 5450

You're missing two crucial lines in your Do loop:

Set olMail = olApp.CreateItem(olMailItem)

and at the end:

Set olMail = Nothing

Try this instead:

Sub SendMail()

    Dim EmailSent, EmailFailed, i As Integer
    Dim StatusSent, StatusFailed As String

    Dim olApp As Outlook.Application
    Set olApp = CreateObject("Outlook.Application")

    Dim olMail As Outlook.MailItem

    EmailSent = 0
    EmailFailed = 0
    StatusFailed = "failed"
    StatusSent = "sent"
    i = 1

    Do
    DoEvents
        Set olMail = olApp.CreateItem(olMailItem)

        With olMail
            .To = Cells(i, 1).Value
            .Subject = "test"
            .CC = ""
            .BCC = ""
            .Importance = olImportanceHigh
            .BodyFormat = olFormatHTML

            .HTMLBody = Cells(i, 2).Value

            If Cells(i, 3) = 1 Then
                .HTMLBody = VBA.Replace(olMail.HTMLBody, "replace_me", Cells(i, 4))
            Else
                .HTMLBody = VBA.Replace(olMail.HTMLBody, "replace_me", Cells(i, 5))
            End If

           .send

        End With

        On Error Resume Next
        olMail.send

        If Err Then
            EmailFailed = EmailFailed + 1
            ActiveSheet.Cells(i, 6).Value = StatusFailed    'change status from pending to failed
        Else
            EmailSent = EmailSent + 1
            ActiveSheet.Cells(i, 6).Value = StatusSent  'change status from pending to sent
        End If

        Set olMail = Nothing

        i = i + 1
    Loop Until i = Range(Range("A1"), Range("A1").End(xlDown)).Count

    If EmailSent = 0 Then
        MsgBox Prompt:="Emails could not be sent"
    Else
        MsgBox Prompt:="Sent emails: " & EmailSent & vbNewLine _
        & "Failed emails: " & EmailFailed
    End If

    On Error GoTo 0
    Set olApp = Nothing

End Sub

Upvotes: 2

Related Questions