Sending Multiple Emails via VBA

[scott56]

Hi,

I have the following routine within an Excel application that is sending emails in a loop using CDO....It works ok....but is really slow as it needs to logon to an SMTP server each time an email send and then send that email.

I want to retain the sending via an SMTP server as it means the Excel application can be deployed on any workstation and does not require Outlook or any other mail program to be installed....but I want to speed up the process..

Is there anyway to do this differently so that I logon to the SMTP server once and then retain that connection while I loop through and send the emails needed ? Or does anyone have any other suggested approaches.....many thanks for any advice

Sub CDOSendMail(strSMTPServerName As String, _
strSendUserName As String, _
strSendPassword As String, _
strServerPort As String, _
strReplyToAddress As String, _
strFromDetails As String, _
blnUseSSL As Boolean, _
strContactEmailAddress As String, _
streMailSubject As String, _
strEmailBody As String, _
blnEmailSent As Boolean, _
streMailFormat As String, _
varReturnErrorNumber As Variant, _
strReturnErrorDescription As String)
'This routine will send an email to the domain and settings set by the user in the User Settings sheet
Dim objMessage As Object
blnEmailSent = True

'Check that the eMail address we are about to use is valid
If Not IsEmailValid(strContactEmailAddress) Then
Call MessageDisplay("Error", "Invalid Email Address", strContactEmailAddress)
blnEmailSent = False
Exit Sub
End If

'If the user is connected to the internet then send the email message
If IsConnected = True Then

Set objMessage = CreateObject("CDO.Message")

objMessage.Subject = streMailSubject
objMessage.Sender = strSendUserName
objMessage.To = strContactEmailAddress

Select Case streMailFormat
Case "Plain Text": objMessage.TextBody = strEmailBody
Case "HTML": objMessage.HTMLBody = strEmailBody
End Select

If strFromDetails <> "Not Specified" Then objMessage.From = strFromDetails
If strReplyToAddress <> "Not Specified" Then objMessage.ReplyTo = strReplyToAddress

'Setup the email configuraiton information
With objMessage.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTPServerName
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = strSendUserName
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = strSendPassword
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = strServerPort
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = blnUseSSL
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
.Update
End With

'Everything is now ready for sending the email...Catch any errors in the Message send process
On Error Resume Next
objMessage.send
If Err <> 0 Then
Call MessageDisplay("Error", "Send Mail Problem")
blnEmailSent = False
varReturnErrorNumber = Err.Number
strReturnErrorDescription = Err.Description
End If

Else
Call MessageDisplay("Error", "Send Mail Problem")
blnEmailSent = False
varReturnErrorNumber = Err.Number
strReturnErrorDescription = "Not Connected to the Internet"
End If
Set objMessage = Nothing

End Sub

[Bob Phillips]

MAybe take the CreateObject out of that procedure, do it before the loop, and pass the object variable through.

[scott56]

The CreateObject step is completed very quickly it is the final Send that takes the time in the process.....so it seems that the authentication and logon to the SMTP server occurs in that step.

This is the step that I am hoping to complete only once as part of the multiple message send...