CODEWITHSUNDEEP
excelvbaoutlook
Vinicius
Vinicius

Reputation: 65

Code for forwarding emails is slow

I send email to a big list of contacts. I don't want to lose the format of the original email.

I am using this code:

Dim emailad, firstname, pretit, midtit, prebod, bod, postbod As String
Dim n As Integer
n = 1

pretit = Sheets(CurrSh).Range("pretit").Value
midtit = Sheets(CurrSh).Range("midtit").Value
prebod = Sheets(CurrSh).Range("prebod").Value
bod = Sheets(CurrSh).Range("bod").Value
postbod = Sheets(CurrSh).Range("postbod").Value

Dim objMail(1 To 500) As Object
Set objitem = GetCurrentItem()

'********** Send e-mail for each e-mail in the list ***********
Set objMail(n) = CreateObject("Outlook.Application")

While (Sheets(CurrSh).Range("emailad_ini").Offset(n, 0).Value <> "")
    emailad = Sheets(CurrSh).Range("emailad_ini").Offset(n, 0).Value
    firstname = Sheets(CurrSh).Range("firstname_ini").Offset(n, 0).Value


    Set objMail(n) = objitem.Forward

    objMail(n).To = emailad
    objMail(n).Subject = pretit & " " & firstname & midtit & "  FWD: " & objitem.Subject
    objMail(n).HtmlBody = "<HTML><BODY><FONT FACE='Arial'><FONT SIZE='2'>" & prebod & " " & firstname & "," & "<br>" & bod & "<br>" & postbod & objMail(n).HtmlBody & "</FONT></FONT></BODY></HTML>"
    objMail(n).Display
    Set objMail(n) = Nothing
    n = n + 1
Wend

Theend:
End Sub

The problem is this code is so slow.

Upvotes: 0

Views: 83

Answers (1)

David W
David W

Reputation: 10184

The strongest suspect for poor performance in this loop is the creation of a new Outlook.Application object for each iteration of the loop. This shouldn't be necessary. Move the Set ObjApp = CreateObject("Outlook.Application") call to just before the WHILE loop and simply re-use the same reference therein.

Revised for OP based on further comment:

I am going to simplify this code to match what I think you're trying to accomplish. I see no need for the large array of mail objects, as you set them to Nothing after they're Displayed. It seems all you want to do is take the current item and send it to each member of your list, customized with their own name as the subject. In that vein, I'd try this:

Dim emailad, firstname, pretit, midtit, prebod, bod, postbod As String
Dim mailApp
Dim newItem 
Dim n As Integer
n = 1

pretit = Sheets(CurrSh).Range("pretit").Value
midtit = Sheets(CurrSh).Range("midtit").Value
prebod = Sheets(CurrSh).Range("prebod").Value
bod = Sheets(CurrSh).Range("bod").Value
postbod = Sheets(CurrSh).Range("postbod").Value

Set objitem = GetCurrentItem()
Set mailApp = CreateObject("Outlook.Application")

'********** Send e-mail for each e-mail in the list ***********

While (Sheets(CurrSh).Range("emailad_ini").Offset(n, 0).Value <> "")

    emailad = Sheets(CurrSh).Range("emailad_ini").Offset(n, 0).Value
    firstname = Sheets(CurrSh).Range("firstname_ini").Offset(n, 0).Value

    Set newItem = mailApp.CreateItem(0) ' Create a new Mailitem; olMailItem = 0

    newItem.To = emailad
    newItem.Subject = pretit & " " & firstname & midtit & "  FWD: " & objitem.Subject
    newItem.HtmlBody = "<HTML><BODY><FONT FACE='Arial'><FONT SIZE='2'>" & prebod & " " & firstname & "," & "<br>" & bod & "<br>" & postbod & objItem.HtmlBody & "</FONT></FONT></BODY></HTML>"

    newItem.Send
    n = n + 1

Wend

Beyond this, what portion (specifically) is slow? Sending 60 copies of this message shouldn't take that long. Are you sure your loop is terminating when you expect (with only 60 names), or is the data in your sheet possibly preventing your termination from occurring when you expect, causing it to run indefinitely?

Upvotes: 1

Related Questions