Error sending bulk emails using Outlook

[highandwild]

Hi all

I'm developing an application where I send emails containing monthly statements to members.

If I don't create an Outlook Application object for each email, as in the code below, I often get an "Operation Failed" error message. I cannot trap it as it is an Outlook message.

What ever I change the fnWait to does not seem to matter.

It works fine as it is but do you have any ideas as to what I can do to avoid creating the Outlook object everytime?

I am using the ClickYes program.

Public Function SendBulkEmails(strSQL) As Boolean
Dim db As Database
Dim rs As Recordset
Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL)
Do While Not rs.EOF

Set appOutLook = CreateObject("Outlook.Application")

Call SendIndividualEmail(rs!Address, rs!Subject, rs!Msg)

Call fnWait(5)

rs.MoveNext

Set appOutLook = Nothing
Loop
rs.Close
db.Close
End Function

Private Function SendIndividualEmail(strAddress, strSubject, strMessage)
Dim MailOutLook As Outlook.MailItem
Dim x As Integer

On Error GoTo Err_Handler:
Set MailOutLook = appOutLook.CreateItem(olMailItem)

With MailOutLook

.BodyFormat = olFormatRichText

.To = strAddress

.Subject = strSubject

.HTMLBody = strMessage

.Send

End With

Set MailOutLook = Nothing

Exit Function
Err_Handler:

MsgBox "An error was encountered." & vbCrLf & "The error message is: " & Err.Description & vbCrLf & strMessage
End Function

Public Function fnWait(intNrOfSeconds As Integer)
Dim varStart As Variant
varStart = Timer
Do While Timer < varStart + intNrOfSeconds
Loop
End Function

 

[c_smithwick]

Have you tried passing in the recordset as a parameter and opening one outlook session to process the entire recordset? Try the below:

Public Function SendBulkEmails(strSQL) As Boolean
Dim db As DAO.Database
Dim rs As DAO.Recordset
 
Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL)
SendEmail rs
 
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
End Function
 
Private Function SendEmail(rst As DAO.Recordset)
Dim appOutlook As Object
Dim MailOutLook As Outlook.MailItem
 
On Error GoTo Err_Handler:
Set appOutlook = CreateObject("Outlook.Application")
 
Do While Not rst.EOF
    Set MailOutLook = appOutlook.CreateItem(olMailItem)
    With MailOutLook
        .BodyFormat = olFormatRichText
        .To = rst!Address
        .Subject = rst!Subject
        .HTMLBody = rst!Msg
        .Send
        fnWait (5)
    End With
    Set MailOutLook = Nothing
    .MoveNext
Loop
 
Set appOutlook = Nothing
Exit Function
Err_Handler:
MsgBox "An error was encountered." & vbCrLf & "The error message is: " & Err.Description & vbCrLf & strMessage
End Function
 
Public Function fnWait(intNrOfSeconds As Integer)
Dim varStart As Variant
 
varStart = Timer
Do While Timer < varStart + intNrOfSeconds
Loop

End Function

 

[highandwild]

I tried that first of all but found that, despite putting a 10 second wait between emails, that I had to open and close Outlook for each email to avoid getting this Outlook error that I cannot trap.

 

[highandwild]

Hey Ho!!!

But that does not produce the errors I was getting.

It seems to be doing exactly the same but seems to work better.

Thanks

HighAndWild