Outlook email performance slow using Excel VBA

Question

Outlook sends emails really slowly.

Moreover my CPU is at 15-20% and my 16G ram is at 50% utilization...so this could be either an issue of code performance or of resource allocation.

I have included my code below:

 'my code
    Sub SendMail(what_address As String, subject_line As String, mail_body As String)

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

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

        With olMail
            .To = what_address
            .Subject = subject_line
            .BodyFormat = olFormatHTML
            .Attachments.Add "C:\Users\User\Documents\Association\Event Brochure\BROCHURE.pdf"
            .HTMLBody = mail_body
            .Send
        End With

    End Sub 'Tells outlook to send an input, with an attachment I selected


    Sub SendMassMail()

    row_number = 1

    Do
    DoEvents
        row_number = row_number + 1
        Dim mail_body_message As String
        Dim name As String
        Dim mrmrs As String
        Dim company_name As String

        mail_body_message = Sheet1.Range("I2")
        name = Sheet1.Range("B" & row_number)
        mrmrs = Sheet1.Range("C" & row_number)
        company_name = Sheet1.Range("D" & row_number)

        mail_body_message = Replace(mail_body_message, "replace_mrmrs_here", mrmrs)
        mail_body_message = Replace(mail_body_message, "replace_name_here", name)
        mail_body_message = Replace(mail_body_message, "replace_company_here", company_name)


        Call SendMail(Sheet1.Range("A" & row_number), "Event Sponsorship", mail_body_message)

    Loop Until row_number = 500

    End Sub

This code is two macros I created in Excel sheet which contains the email addresses in Column A, Names in Column B, Mr/Mrs in Column C, the company in Column D, and finally the message body in cell I2, which has key words to be replaced for each recipient.

Now regarding the resource allocation. In task manager I gave both excel.exe and Outlook.exe a high priority.

Is my code running badly because I call another function when I use Call SendMail?

Is my code running badly because I use DoEvent? That is the only method I know...so if you suggest a different one than DoEvent please explain what it does.

Answer 1

Here's a quick rewrite where I've:

1. Put all the code into a single routine. We create the outlook application once and send many times from the one instance
2. Switched to a For Each loop which is a little cleaner
3. Removed the DoEvents into a comment. IF you absolute need to be able to break code execution while it's running then you'll want to keep DoEvents in your loop. If you don't care though and just want the thing to run as fast as possible, then leave it out. I would suggest (as @JoshEller noted) that saving these emails as drafts first might be the better alternative. Then you can send manually from your outlook catching any mistakes that may have been made before it's too late (and embarrassing).

Sub SendMassMail()  
    'Create your outlook object once:
    Dim olApp As Outlook.Application
    Set olApp = CreateObject("Outlook.Application")

    'Declare your mail object
    Dim olMail As Outlook.MailItem

    'Some variables used in the loop. Declare outside:
    Dim mail_body_message As String
    Dim name As String
    Dim mrmrs As String
    Dim company_name As String

    'Do your loop. Using a for loop here so we don't need a counter
    Dim rngRow as Range
    For each rngRow in Sheet1.Range("B2:B500").Rows
        'No reason to do this here
        'DoEvents

        mail_body_message = Sheet1.Range("I2")
        name = rngRow.Cells(1, 2).value 'Column B
        mrmrs = rngRow.Cells(1, 3).Value 'Column C
        company_name = rngRow.Cells(1, 4).value 'Column D

        mail_body_message = Replace(mail_body_message, "replace_mrmrs_here", mrmrs)
        mail_body_message = Replace(mail_body_message, "replace_name_here", name)
        mail_body_message = Replace(mail_body_message, "replace_company_here", company_name)

        'Generate the email and send
        Set olMail = olApp.CreateItem(olMailItem)

        With olMail
            .To = rngRow.Cells(1,1).value 'Column A
            .Subject = "M&A Forum Event Sponseorship"
            .BodyFormat = olFormatHTML
            .Attachments.Add "C:\Users\User\Documents\Association\Event Brochure\BROCHURE.pdf"
            .HTMLBody = mail_body_message
            .Send

            'Instead of .send, consider using:
            '.Save
            '.Close
            'Then you'll have it as a draft and you can send from outlook directly
        End With        

    Next rngRow

    'Destroy the outlook application
    Set olApp = Nothing

End Sub