No longer able to send e-mails with VBA and google smtp

619 Views Asked by At

I need to periodically send e-mails and I used the following code for years:

Function SSLSendMail(sTO As String, sFROM As String, sSubject As String, sText As String, sServer As String, _
    sUser As String, sPassword As String, Optional sAttach As String, Optional sCC As String, Optional sBCC As String) As Boolean

    Dim ObjSendMail As Object
    Set ObjSendMail = CreateObject("CDO.Message")
    Dim iConf As Object
    Set iConf = CreateObject("CDO.Configuration")

    With iConf.Fields 'Flds
        .Item(cdoSendUsingMethod) = cdoSendUsingPort    ' 2
        .Item(cdoSMTPAuthenticate) = cdoBasic           ' 1
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True ' If use SSL set to True, if not, set to False
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
        .Item(cdoSendUserName) = sUser
        .Item(cdoSendPassword) = sPassword
        .Item(cdoSMTPServer) = sServer
        .Item(cdoSMTPConnectionTimeout) = 10
        .Update
    End With

    Set ObjSendMail.Configuration = iConf
    With ObjSendMail
        .To = sTO
        .Subject = sSubject
        .from = sFROM
        .TextBody = sText
        If sAttach > "" Then
            .AddAttachment sAttach
        End If
        If sCC > "" Then
            .cc = sCC
        End If
        If sBCC > "" Then
            .BCC = sBCC
        End If
        On Local Error GoTo invalidTo
        .Send
        On Local Error GoTo 0
    End With

    Set ObjSendMail = Nothing
    Set iConf = Nothing
    SSLSendMail = True
    Exit Function

invalidTo:
    Debug.Print "Error on " & sTO & ": " & Err.description
    Err.Clear
    SSLSendMail = False
End Function

In the last days, I get error 0x80040217 and the mail is not sent. After some investigation, I found that Google changed the authentication method from Basic to OAuth2 or, at least, that is what I have to change in my Thunderbird client in order to be able to send mails. I have seen an answer to a similar question suggesting to use Outlook object, but that is not applicable for a series of reasons: I don't have any outlook user configured (and I don't want to!), the "sender" seems not dynamically specified, etc. I guess I have to change .Item(cdoSMTPAuthenticate) = cdoBasic to something else, but I cannot find anything related to OAuth2.

1

There are 1 best solutions below

0
Resca On

After days and days of unsuccessfully testing changes in that code, I finally realized the problem was in the SMTP server only. I had to access my Google configuration page, ask for a second level security for the specific machine on which the Excel VBA is running and I got an encrypted password, based on my regular password, I guess. Using that password, the above code works fine, as before. Thanks Google for making our life more difficult!