troubleshooting Question

Problems with E-Mailing through VBA using CDO

Avatar of Jeanette Durham
Jeanette DurhamFlag for United States of America asked on
Windows Server 2003Microsoft AccessProgramming
18 Comments1 Solution6216 ViewsLast Modified:
Hello experts!

So here is our situation.  We have a Access database that has a utility to write up and send an email.  I have 2 different machines here both running Windows 2003 Server.  One of the machines this code works great.  Never had a problem with it.  But on the other machine, of course the one I need it to work on it, the code does not work at all and produces the following error:

There was an error.  Please hit the send button again to send the remaining emails.
The error was:  
-2147220973, The transport failed to connect to the server.:

When I do this on my other server, it works fine.  Thusly, I suspect my code is fine but there is some sort of configuration issue on the computer.  I have all mail accounts that are set up on the server that works set up on the server that doesn't work as far as I know as well.  Here is my code.

'this sends an email, receivers an email to send to, and the message text.  

Public Function SendAnEmail(trustorEmail$, amessageText$) As Boolean
    Dim sEmail$, sEmailText$, sAccountEmail$, sAccountPass$, sMsgText$, sMsgHTML$
    'Get Account Info
    sAccountEmail = ConfigSettings.GetUserConfig("AccountEmail")
    sAccountPass = ConfigSettings.GetUserConfig("AccountPassword")
    If sAccountEmail = "" Or sAccountPass = "" Then
        MsgBox "Invalid email account info, must have account to send from. Please set the fields <ReportAccountEmail> and " & _
            "<ReportAccountPassword> to set the approriate user info.", vbExclamation
        Exit Function
    End If
    If amessageText = "" Then Exit Function 'this means it didn't pull up any records to send
    Dim myEmail As New SendEmail
    'Setup and Send me an email
    Dim iNumSent As Integer
    With myEmail
        .AddRecipient trustorEmail
        .BodyHTML = Replace(amessageText, vbCrLf, "<br/>")
        .BodyText = amessageText
        .Subject = cEmailSubject
        .Sender = sAccountEmail
        .UserName = sAccountEmail
        .Password = sAccountPass
    End With
    iNumSent = myEmail.SendEmail  'Send it!
    If iNumSent > 0 Then
        SendAnEmail = True
    Else:  SendAnEmail = False
    End If
End Function

'this is the class that makes creates the cdo message

Option Compare Database

'This class was written by Jeffrey Durham on 2/5/2010
'It uses CDO to directly send email messages through the network to a remote SMTP server
'  It accepts a username and password for Authentication (for anonymous, don't supply them)

'Set the constants below to configure the defaults for the class to work on your computer
'  These values can also all be set through properties on this class

Private Const cDefaultSMTPServer$ = ""
Private Const cDefaultSMTPPort = 3535
Private Const cDefaultTimeout = 60

'########## CDO Email Constants

'Send Message Using..
Private Const cdoSendUsingPickup = 1        'Sends message using pickup directory
Private Const cdoSendUsingPort = 2          'Sends message through network. Must use this to use Delivery Notification

'Security Settings
Private Const cdoAnonymous = 0              'Do not authenticate w/ server
Private Const cdoBasic = 1                  '(clear text) must supply user name + pass with config schema
Private Const cdoNTLM = 2                   'The current process security context is used to authenticate with the service

'DSN; Delivery Status Notifications
'Note: Sadly, I was unable to get this to work. Setting CDO.Message.DSNOptions to any of these values caused
'  the message not to be sent at all, no errors thrown
Private Const cdoDSNDefault = 0             'No DSN commands are issued
Private Const cdoDSNNever = 1               'No DSN commands are issued
Private Const cdoDSNFailure = 2             'Return a DSN if delivery fails
Private Const cdoDSNSuccess = 4             'Return a DSN if delivery succeeds
Private Const cdoDSNDelay = 8               'Return a DSN if delivery is delayed
Private Const cdoDSNSuccessFailOrDelay = 14 'Return a DSN if delivery succeeds, fails, or is delayed


Private m_SMTPServer As String
Private m_SMTPPort As Integer               'This is the outgoing SMTP Server Port
Private m_Timeout As Integer                'How long before email times out
Private m_UserName As String                'SMTP Server Account Name <>
Private m_Password As String                'SMTP Password used for authentication
Private m_Sender As String
Private m_Subject As String
Private m_BodyText As String
Private m_BodyHTML As String
Private m_bRequestReceipt As Boolean

Private m_colRecipients As Collection       'Stores list of recipient's addresses
Private m_colAttachments As Collection      'Stores list of file path names to send

Public Property Let SMTPServer(ByVal strSMTPServer As String)
    m_SMTPServer = strSMTPServer
End Property
Public Property Get SMTPServer() As String
    SMTPServer = m_SMTPServer
End Property

Public Property Let SMTPPort(ByVal intSMTPPort As Integer)
    m_SMTPPort = intSMTPPort
End Property
Public Property Get SMTPPort() As Integer
    SMTPPort = m_SMTPPort
End Property

Public Property Let TimeOut(ByVal intTimeout As Integer)
    m_Timeout = intTimeout
End Property
Public Property Get TimeOut() As Integer
    TimeOut = m_Timeout
End Property

Public Property Let UserName(ByVal strUserName As String)
    m_UserName = strUserName
End Property
Public Property Get UserName() As String
    UserName = m_UserName
End Property

Public Property Let Password(ByVal strPassword As String)
    m_Password = strPassword
End Property
Public Property Get Password() As String
    Password = m_Password
End Property

Public Property Let Sender(ByVal strSender As String)
    m_Sender = strSender
End Property
Public Property Get Sender() As String
    Sender = m_Sender
End Property

Public Property Let Subject(ByVal strSubject As String)
    m_Subject = strSubject
End Property
Public Property Get Subject() As String
    Subject = m_Subject
End Property

Public Property Let BodyText(ByVal strBodyText As String)
    m_BodyText = strBodyText
End Property
Public Property Get BodyText() As String
    BodyText = m_BodyText
End Property

Public Property Let BodyHTML(ByVal strBodyHTML As String)
    m_BodyHTML = strBodyHTML
End Property
Public Property Get BodyHTML() As String
    BodyHTML = m_BodyHTML
End Property

Public Property Let RequestReceipt(ByVal bRequestReceipt As Boolean)
    m_bRequestReceipt = bRequestReceipt
End Property
Public Property Get RequestReceipt() As Boolean
    RequestReceipt = m_bRequestReceipt
End Property

'######### CLASS EVENTS

Private Sub Class_Initialize()
    'Initialize Class Objects
    Set m_colRecipients = New Collection
    Set m_colAttachments = New Collection
    'Set Default Settings for Class Properties
    m_SMTPPort = cDefaultSMTPPort
    m_SMTPServer = cDefaultSMTPServer
    m_Timeout = cDefaultTimeout
End Sub

Private Sub Class_Terminate()
    'Destroy Class Objects
    Set m_colRecipients = Nothing
    Set m_colAttachments = Nothing
End Sub


Public Function SendEmail() As Long
    'Main Routine which sends out the Emails
    '  Returns the number of emails sent
    If m_colRecipients.Count = 0 Then Exit Function 'no emails? no send.
    Dim objMsg As Object, objConf As Object
    Set objConf = CreateObject("CDO.Configuration") 'all config scheme defined on
    Dim Authenticate As Integer, bHasAttachments As Boolean
    Authenticate = IIf(m_UserName = "" And m_Password = "", cdoAnonymous, cdoBasic)
    bHasAttachments = m_colAttachments.Count > 0
    'Configure CDO Configuration for Authentication and Send Through a Network to remote SMTP Server
    Set objFlds = objConf.Fields
    With objFlds
        .Item("") = cdoSendUsingPort
        .Item("") = m_SMTPServer
        .Item("") = m_Timeout
        .Item("") = m_SMTPPort
        .Item("") = Authenticate
        .Item("") = m_UserName
        .Item("") = m_Password
    End With
    Set objFlds = Nothing
    'myFuncs.UseAccessMeter "Sending emails.. (" & m_colRecipients.Count & ")", 0, m_colRecipients.Count
    Dim recipient As Variant, knt As Integer
    For Each recipient In m_colRecipients
        knt = knt + 1
        Set objMsg = CreateObject("CDO.Message")
        With objMsg
            Set .Configuration = objConf
            .To = recipient
            .From = m_Sender
            .Subject = m_Subject
            .TextBody = m_BodyText
            .HTMLBody = m_BodyHTML      'use .HTMLBody to send HTML email.
            'Add attachments
            If bHasAttachments = True Then
                Dim strAttach As Variant
                For Each strAttach In m_colAttachments
                    .AddAttachment strAttach
            End If
            If m_bRequestReceipt = True Then
                .Fields("urn:schemas:mailheader:return-receipt-to") = m_Sender
            End If
            'Send the Email!
            'myFuncs.UseAccessMeter "Sending: " & recipient, knt
            On Error GoTo MyErrHandler
            On Error GoTo 0
            SendEmail = SendEmail + 1   'Returns the number of emails sent
        End With
        Set objMsg = Nothing
    Set objMsg = Nothing
    Set objConf = Nothing
    Exit Function
    MsgBox "There was an error. Please hit the send button again to send the remaining emails." & _
        vbCrLf & "The Error was: " & vbCrLf & Err.Number & ", " & Err.Description, vbExclamation
    GoTo CleanupAndExit
End Function

'######### Add Recipients

Public Sub AddRecipient(ByVal sEmail$)
    m_colRecipients.Add sEmail
End Sub

'######### Add Attachments

Public Sub AddAttachment(ByVal sPathname$)
    m_colAttachments.Add sPathname
End Sub


Our community of experts have been thoroughly vetted for their expertise and industry experience.

Join our community to see this answer!
Unlock 1 Answer and 18 Comments.
Start Free Trial
Learn from the best

Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.

Andrew Hancock - VMware vExpert
See if this solution works for you by signing up for a 7 day free trial.
Unlock 1 Answer and 18 Comments.
Try for 7 days

”The time we save is the biggest benefit of E-E to our team. What could take multiple guys 2 hours or more each to find is accessed in around 15 minutes on Experts Exchange.

-Mike Kapnisakis, Warner Bros