VBA send email in outlook 2016 efficiency worsened? - excel

Question

There is a simple piece of standard VBA code that I use to send emails by looking through a list and generating around 2000 email to the draft folder. In my old version of excel & outlook 2012, it took only around 20 min or less to generate all. But after migrated to versions of 2016, the same piece of code take up to 4 hour. Is there any way to speed it up? Thanks!
Function CreateEmail(ToSend As String, ccs As String) As Integer
Dim olapp As Outlook.Application
Dim olemail As Outlook.MailItem
Dim OutlookTemplate As String
OutlookTemplate = "TemplatePath.oft"
Set olapp = New Outlook.Application
Set olemail = olapp.CreateItemFromTemplate(OutlookTemplate)
Dim recipientCheck As Outlook.recipient
With olemail
.HTMLBody ="Body String"
.SentOnBehalfOfName = "sender email address"
.Subject = "subject string"
.To = ToSend
.CC = ccs
.Attachments.Add "attachment.pdf" ' pdf size is 200k
'this is a check for tosend email addresses,
'already tried remove this piece of code, no significant improvement there
Dim recipient As Variant
Dim i, j As Integer
For Each recipient In .recipients
recipient.Resolve
Next
.Save
End With
CreateEmail = 1
End Function

Answer 1

Of course, in the code each time you create a new Outlook Application instance. You can optimize the codebase by extracting such pieces into separate methods (outer) that may call the CreateEmail multiple times only for creating items.
Dim olapp As Outlook.Application
Set olapp = New Outlook.Application
Function CreateEmail(app as Outlook.Application, ToSend As String, ccs As String) As Integer
Dim olemail As Outlook.MailItem
Dim OutlookTemplate As String
OutlookTemplate = "TemplatePath.oft"
Dim recipientCheck As Outlook.recipient
Set olemail = olapp.CreateItemFromTemplate(OutlookTemplate)
With olemail
.HTMLBody ="Body String"
.SentOnBehalfOfName = "sender email address"
.Subject = "subject string"
.To = ToSend
.CC = ccs
.Attachments.Add "attachment.pdf" ' pdf size is 200k
'this is a check for tosend email addresses,
'already tried remove this piece of code, no significant improvement there
Dim recipient As Variant
Dim i, j As Integer
For Each recipient In .recipients
recipient.Resolve
Next
.Save
End With
CreateEmail = 1
End Function
You may also find the following articles helpful:
How To: Create and send an Outlook message programmatically
How to create and show a new Outlook mail item programmatically: C#, VB.NET
How To: Create a new Outlook message based on a template
How To: Fill TO,CC and BCC fields in Outlook programmatically