Code for sending email 'transport' error

Harris@Z

Registered User.
Local time
Today, 03:11
Joined
Oct 28, 2019
Messages
104
Hi all,

Wonder if anyone can give input why I am getting an error, or what may have changed.

I have been using the code below in Microsoft Access DB for years to connect to smtp.office365.com and send emails.
Out of the blue, around 4 weeks ago, I started receiving an error: "transport failed to connect to the server" Error -2147220973
Nothing had changed. I can login to Office 365 with the username and password I use (disguised below). I have also tried my team members username and passwords too.

I have the same error working on my laptop at work, and my desktop at home.
My team members have also experienced the same error.
I have tried different ports e.g., 25 / 465 / 587

The script works perfectly if I use the smtpserver of a webhosting company that hosts our website, e.g., gvam1287.siteground.biz

Microsoft tells me that they will not assist with custom code.
They tell me that smtp.office365.com is working perfectly and that cannot be the fault.

Anyone have any ideas or experienced the same problem?

Code:
Function TestE()
Dim objMessage
Set objMessage = CreateObject("CDO.Message")

With objMessage
    .Configuration.Load -1 ' CDO Config
    .To = "joeblogs@zzzz.com"
    .From = "susanblogs@zzzy.com"
    .Subject = "Test Email"
    .TextBody = "This is a test email sent using CDO."
    
    ' SMTP Configuration
    With .Configuration.fields
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.office365.com"      
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465                       ' 587 / 25
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = MyUserName    
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = MyPassword
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 10
        .Update
    End With

    ' Send the email
    .Send
End With
Set objMessage = Nothing
MsgBox "done"
End Function
 
I found someone working with CDO and an Office gateway system. By the way, your error -2147220973 needs to be looked at as hexadecimal, for which the translation is 0x80040213. Most Microsoft errors are reported as hexadecimal codes.


In that larger article are three most likely causes of that error:
1. Incorrect SMTP server / port
2. Incorrect login/password
3. FROM address not valid according to SMTP server (wrong domain)

Another article leads to this page:


One last question to ask of your IT staff: Have they altered the rules for systems connecting to that mail gateway? The reason is that gateways, if advanced enough, can tell what program is sending the message and can establish rules to disallow the connection. I had a case where I had to ask our IT security person to do an ALLOW for SMTP originating from MSACCESS.EXE, after which everything went off without problems.
 
Hi The Doc Man,

Much appreciated, thank you! Lots of information to assess and to check.

I do not think it is these three for I have assessed, checked, and thoroughly discounted these as possibilities:
1. Incorrect SMTP server / port
2. Incorrect login/password
3. FROM address not valid according to SMTP server (wrong domain)

Thanks for the advice on other potential causes, I will assess these possibilities.

Harris
 
I suspect Colins excellent application can assist you:
 
@pbaldy
Thank you for the link. This is the site I originally looked at when developing my code.
I tried to code now again, and unfortunately fails to work.

@Minty
Thanks for the link too. I use CDO Email Tester to check whether my parameters work, and they were successfully working till recently.
Tried CDO Email Tester again, and although worked previously with exact same parameters, now no longer sends email.
I reached out to Colins and he could not find any obvious error in my coding, but was unable to guide me to a possible cause for the code to no longer work.

Incredibly frustrating!
 
Hi Harris
For the benefit of others, this info is from the help guide supplied with my CDO EMail Tester app linked by @Minty in post #5:

1740689997082.png


As mentioned in my email reply, I've been using CDO for almost 20 years and I've never yet found any other reasons for that error.
Might be worth checking if that port has been blocked.

On the unlikely event there is another reason, please do let me know
Of course, sending the email fails on the first error arising. So its possible that if you fix that issue, there is another error to follow

I didn't check your code previously due to other commitments
The only line that I'd query is: .Configuration.Load -1

That isn't in my code and I've no idea why its there. What happens if you comment it out?
 
Hi Colin,

Thanks for your contribution!

I did comment out .Configuration.Load-1 with no effect on the result.

Interestingly, I uploaded my database to a computer in the USA a few minutes ago, and the test email failed. In other words, code not influenced by my fiber/internet provider.

I am curious - if you use the code I pasted above, substitute your login username and password, does it work?

Harris
 
I don't have an Office email account so can't test it directly
 
It does not work for me, using my creds and From address.
 
Working code with personal bits removed:

Code:
Option Compare Database
Option Explicit

Const cdoSendUsingPickup = 1 'Send message using the local SMTP service pickup directory.
Const cdoSendUsingPort = 2 'Send the message using the network (SMTP over the network).

Const cdoAnonymous = 0 'Do not authenticate
Const cdoBasic = 1 'basic (clear-text) authentication
Const cdoNTLM = 2 'NTLM

Function SendCDOMail(sTo As String, sSubject As String, sBody As String, _
  Optional sBCC As Variant, Optional AttachmentPath As Variant)
  On Error GoTo Error_Handler
  Dim objCDOMsg          As Object
  Dim i                  As Long

  'credit to https://www.devhut.net/vba-cdo-mail/

  '    Set objCDOMsg = New CDO.Message             'Early Binding -> Microsoft CDO for Windows 2000 Library
  Set objCDOMsg = CreateObject("CDO.Message")  'Late Binding

  'CDO Configuration
  With objCDOMsg.Configuration.Fields
    '
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort
    'Server port (typically 25, 465, 587) '***The next line is commented out because of the use of SSL encryption***
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
    'SMTP server IP or Name
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.office365.com"
    'Type of authentication, NONE, Basic (Base64 encoded), NTLM
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic
    'SMTP Account User ID
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "paulb@abc.com"
    'SMTP Account Password
    .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "PwdHere"
 
    'Number of seconds to wait for a response from the server before aborting
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 10
    'Use SSL for the connection (False or True) -> If using SSL, do not specify the Port above
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True  '!!!!Always use some form of encryption!!!!
    'Use TLS for the connection (False or True) - See the note below
    '.Item("http://schemas.microsoft.com/cdo/configuration/sendtls") = True 'Does not work in CDO
    .Update
  End With

  'CDO Message
  objCDOMsg.Subject = sSubject
  objCDOMsg.From = "paulb@abc.com"
  objCDOMsg.To = sTo
  objCDOMsg.replyTo = "paulb@abc.com"
  'objCDOMsg.TextBody = sBody 'This would be for plain text e-mails
  objCDOMsg.HTMLBody = sBody  'This would be for HTML formatted e-mails using HTML tags
  ' Add attachments to the message.
  If Not IsMissing(AttachmentPath) Then
    If IsArray(AttachmentPath) Then
      For i = LBound(AttachmentPath) To UBound(AttachmentPath)
        If AttachmentPath(i) <> "" And AttachmentPath(i) <> "False" Then
          objCDOMsg.AddAttachment AttachmentPath(i)
        End If
      Next i
    Else
      If AttachmentPath <> "" Then
        objCDOMsg.AddAttachment AttachmentPath
      End If
    End If
    
    If Not IsMissing(sBCC) Then
      objCDOMsg.bcc = sBCC
    Else
      objCDOMsg.bcc = "paulb@abc.com"
    End If
  End If

  '****Do not forget although we can configure the following, the recipient can disable the functionality
  '       at their end on the server/email client, so this truly is not reliable!
  'Read receipt
  '    objCDOMsg.Fields(CdoMailHeader.cdoReturnReceiptTo) = "accounts@hitterslongrun.com"                    'Early Binding
  '  objCDOMsg.fields("urn:schemas:mailheader:return-receipt-to") = "accounts@hitterslongrun.com"           'Late Binding
  '  'Delivery receipt
  '  '    objCDOMsg.Fields(CdoMailHeader.cdoDispositionNotificationTo) = "accounts@hitterslongrun.com"          'Early Binding
  '  objCDOMsg.fields("urn:schemas:mailheader:disposition-notification-to") = "accounts@hitterslongrun.com"  'Late Binding

  objCDOMsg.Send

Error_Handler_Exit:
  On Error Resume Next
  Set objCDOMsg = Nothing
  Exit Function

Error_Handler:
  MsgBox "The following error has occurred." & vbCrLf & vbCrLf & _
    "Error Number: " & Err.Number & vbCrLf & _
    "Error Source: SendCDOMail" & vbCrLf & _
    "Error Description: " & Err.Description, _
    vbCritical, "An Error has Occurred!"
  Resume Error_Handler_Exit
End Function
 
Just tested with a different email account.
It worked fine with and without the line: .Configuration.Load -1 and a 60 second timeout
 

Users who are viewing this thread

Back
Top Bottom