VBA SENDING EMAIL ERROR transport error code was 0x80040217

Cannot send email with VBA, have looked up forums the responds are two step verification code activation. I did it, I copied the 16 digits to my password. Even though, the same error occurs. Anyone has an idea why? ... I heard that after May'22 GMAIL has declined less riskable applications issue. If so, what to do now? How can automate sending emails through vba

code is below;

Sub SendMail()
    Dim objEmail
On Error GoTo err:
    Const cdoSendUsingPort = 2  ' Send the message using SMTP
    Const cdoBasicAuth = 1      ' Clear-text authentication
    Const cdoTimeout = 60       ' Timeout for SMTP in seconds

     mailServer = "smtp.gmail.com"
     SMTPport = 465     '25 'SMTPport = 465
     mailusername = "r***@gmail.com"
     mailpassword = "****"

     mailto = "r***@hotmail.com"
     mailSubject = "my test-deleteme"
     mailBody = "This is the email body"

    Set objEmail = CreateObject("CDO.Message")
    Set objConf = objEmail.Configuration
    Set objFlds = objConf.Fields

    With objFlds
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = mailServer
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = SMTPport
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = cdoTimeout
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasicAuth
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = mailusername
    .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = mailpassword
        .Update
    End With

    objEmail.To = mailto
    objEmail.From = mailusername
    objEmail.Subject = mailSubject
    objEmail.TextBody = mailBody
    'objEmail.AddAttachment "C:\report.pdf"
    objEmail.Send

    Set objFlds = Nothing
    Set objConf = Nothing
    Set objEmail = Nothing
err:
Debug.Print err.Description, err.Number, err.Source
End Sub

I took two step verification steps from this web site ; https://wellsr.com/vba/2020/excel/vba-send-email-with-gmail/

Solution

This code worked for me, just tested it with app password on my Google account:

'Macro to send emails using Gmail
'From: https://qdatalab.com
Sub SendEmail()

    Dim from, recipient, cc, bcc, password, subject, body, attachment As String, enable_html As Boolean

    'CONFIGURATION - EDIT THIS
    from = "[email protected]" 'Insert your own email
    recipient = "[email protected]" 'Insert recipient email
    cc = "" 'Insert CC email recipient (optional)
    bcc = "" 'Insert BCC email recipient (optional)
    password = "your password" 'Insert your Gmail password or App password (if you have 2-factor authentication enabled)
    subject = "Email subject" 'Email subject
    body = "Body text" 'The body text of the email
    enable_html = False 'Set to True if you want to add HTML to the body text of the email (optional)

    'NO NEED TO EDIT ANYTHING BELOW THIS
    On Error GoTo Err
    Dim mailObj, configObj As Object, fields As Variant, msConfigURL As String

    msConfigURL = "http://schemas.microsoft.com/cdo/configuration"

    'Create objects
    Set mailObj = CreateObject("CDO.Message")
    Set configObj = CreateObject("CDO.Configuration")
    configObj.Load -1
    Set fields = configObj.fields

    'Set email properties
    With mailObj
        .subject = subject
        .from = from
        .to = recipient
        .cc = cc
        .bcc = bcc
    End With

    If enable_html = True Then
        With mailObj
            .htmlbody = body
        End With
    Else
        With mailObj
            .textbody = body
        End With
    End If

    With fields
        .Item(msConfigURL & "/smtpusessl") = True
        .Item(msConfigURL & "/smtpauthenticate") = 1
        .Item(msConfigURL & "/smtpserver") = "smtp.gmail.com"
        .Item(msConfigURL & "/smtpserverport") = 465
        .Item(msConfigURL & "/sendusing") = 2
        .Item(msConfigURL & "/sendusername") = from
        .Item(msConfigURL & "/sendpassword") = password
        .Update
    End With

    mailObj.Configuration = configObj
    mailObj.Send

    Set mailObj = Nothing
    Set configObj = Nothing

    Exit Sub

Exit_Err:
    Set mailObj = Nothing
    Set configObj = Nothing
    End

Err:
    MsgBox "An error ocurred." & vbNewLine & Err.Number & ": " & Err.Description
    Resume Exit_Err
End Sub

Credits to Qdatalab.com, where the code is from. It seems like the problem is with your CDO.Configuration.

Make sure your region in Windows is set to English (United States) or English (United Kingdom), and you have the necessary references enabled in the editor. I believe this includes OLE Automation and Microsoft CDO for Windows 2000 Library.

Make sure to create an app password to use, instead of your own login password.

Go to your Google account settings: myaccount.google.com
Click Security
Under the Signing in to Google tab, click on App passwords
Select app “Mail” and select device “Windows Computer” and click the GENERATE button
Copy the password to your code