CDO/SMTP email No longer working

[SeniorTom]

I have a routine to send email using CDO (found on the web, but not sure where). I have been using it for about 4 months and only had one problem,"The transport failed to connect to the server." . I waited about an hour and all was well.





I reference a excel file using vlookup to get the email address. The file had been updated and caused a "#NAME" error. My error checking did not/does not check for that error and I sent it to the server. Now I can't send any email using CDO/SMTP. I can send from my gmail account directly. If I step though the routine and get to send, it just hangs.



Is there a way to clear the CDO/SMTP server or do I have to address the problem differently?

CDO_Mail.Subject = strSubject
CDO_Mail.From = strFrom
CDO_Mail.To = strTo
CDO_Mail.TextBody = strBody
CDO_Mail.CC = strCc
CDO_Mail.BCC = strBcc
CDO_Mail.Send



Regards,
Tom

 

[SeniorTom]

Additional info Error after timeout "The transport failed to connect to the server."

 

[SeniorTom]

Geek squad suggested using port 465 instead of 25. Fixed it, reason unknown.

 

[pulsar777]

Hey, is it possible to combine TextBody with HtmlBody ? First part a text and second part of the message an embedded image / html ?

 

[SeniorTom]

Pulsar,
Thanks for the feedback. The port change took care of the problem.
Tom

 

[pulsar777]

I'm glad to hear that Tom!
I was wondering since you've been using it, if you might know how to combine TextBody and HTMLBody in 1 CDO.Message.
I've also made separate thread for this but didn't have luck for any replies.

 

[SeniorTom]

This is the code i found on the web. I'm sorry I didn't save/record the authors name or URL. Hope it helps.

Public Sub Send_emails()
' Routine to send emails to those that responded to play dates Google form
    Dim CDO_Mail As Object
    Dim CDO_Config As Object
    Dim SMTP_Config As Variant
    Dim strSubject As String
    Dim strFrom As String
    Dim strTo As String
    Dim strCc As String
    Dim strBcc As String
    Dim strBody As String
    ' Response file Column "C" is where email address is located
 Const emailColumn As String = "C"
ResponseFileName.Activate
With Sheet1
For mailcount = 2 To LastRow
    strSubject = "Results of your course selection"
    strFrom = "cpmensgolfassoc@gmail.com"
    strTo = .Range(emailColumn & mailcount).Value
    strCc = ""
    strBcc = ""
   strBody = "Your course selections are(is) recorded as:  " & .Range("D" & mailcount).Value
Debug.Print Time
Debug.Print strTo
Debug.Print strBody
    Set CDO_Mail = CreateObject("CDO.Message")
    On Error GoTo Error_Handling
    
    Set CDO_Config = CreateObject("CDO.Configuration")
    CDO_Config.Load -1
    
    Set SMTP_Config = CDO_Config.Fields

    With SMTP_Config
     .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
     .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
     .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
     .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "mensgolfassoc@gmail.com"
     .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "passwd"
     .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
                        '25 & 465 are valid ports and sometimes may fail. Change to the other if you can't connect
     .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
     .Update
    End With

    With CDO_Mail
     Set .Configuration = CDO_Config
   
    End With

    CDO_Mail.Subject = strSubject
    CDO_Mail.From = strFrom
    CDO_Mail.to = strTo
    CDO_Mail.TextBody = strBody
    CDO_Mail.CC = strCc
    CDO_Mail.BCC = strBcc
    CDO_Mail.Send

Error_Handling:
    If Err.Description <> "" Then
        Debug.Print Err.Description
        msg = "An Error has occured with a name, Insure LAST name only or,  " & vbNewLine + vbNewLine
        msg = msg & "one of these special names " & vbNewLine + vbNewLine
        msg = msg & " Remove sent rows from the file and rerun"
        MsgBox msg, vbExclamation
        ' MsgBox Err.Description
    End If


 Next mailcount
 MsgBox "Emails sent. Confirm by checking Gmail ""sent Mail"" folder"

 End With
End Sub