System Error When Sending Mass Emails

[rhurst89]

Hi,

I'm trying to program a macro button to send mass emails. However, when I run the code, I get an error that reads "System Error &H80004005 (-2147467259). Unspecified error." When I uncomment the "Display" option, it'll display all of the emails exactly as I need them to. However, when I uncomment the "Send" option, I get the error. Does anyone have an idea of what might be the issue? This is my code:

Sub send_mass_email()
Dim i As Integer
Dim name, email, trades, pgain, tgain, dfrom, dto, ddue, tdue, subject As String
Dim OutApp As Object
Dim OutMail As Object

body = ActiveSheet.TextBoxes("TextBox 1").Text

i = 4
'Loop down name column starting at row 2 column 1
Do While Cells(i, 1).Value <> ""

name = Cells(i, 3).Value
email = Cells(i, 5).Value
trades = Cells(i, 6).Value
pgain = Cells(i, 7).Value
tgain = Cells(i, 8).Value
dfrom = Cells(i, 9).Value
dto = Cells(i, 10).Value
ddue = Cells(i, 11).Value
tdue = Cells(i, 12).Value
subject = ActiveSheet.TextBoxes("TextBox 2").Text

'Replace place holders
body = Replace(body, "C1", name)
body = Replace(body, "C2", dfrom)
body = Replace(body, "C3", dto)
body = Replace(body, "C4", trades)
body = Replace(body, "C5", tgain)
body = Replace(body, "C6", pgain)
body = Replace(body, "C7", tdue)
body = Replace(body, "C8", ddue)

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = email
.subject = subject
.body = body
'.display
.Send
End With

'reset body text
body = ActiveSheet.TextBoxes("TextBox 1").Text

i = i + 1
Loop

Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Email(s) Sent!"

End Sub

 

[Candyman8019]

I suspect it may be a timing issue, ie too many emails trying to be sent at once. Try adding a brief delay after each message to allow it time to actually send...perhaps something like:
Application.Wait Now + TimeValue("00:00:01")