Office: (Office 2010) Emails per VBA senden nicht mehr möglich

Hallo,

das nachfolgende VB-Script nutze ich seit vielen Jahren um vierteljährlich als Schatzmeister mehrere Emails mit PDF-Anlagen für einen Verein zu versenden. Das hat auch bis Juni/Juli 2021 einwandfrei funktioniert. Seitdem bekomme ich die folgende Fehlermeldung und habe es nicht geschafft, das Script wieder zum Laufen zu bringen.

Die Nachricht konnte nicht an den SMTP-Server gesendet werden. Der Transportfehlercode lautet 0x80040217. Die Serverantwort lautet not available​

Es wäre super, wenn mir hier Jemand weiterhelfen könnte.

P.S.:

• In meiner Fritzbox sind und waren keine Portfreigaben eingerichtet.
• Ich habe MS Office 2010 Professional, seit ca. 2 Jahren muss ich alle paar Wochen die Reparaturfunktion nutzen, wenn ich Serienbriefe schreiben möchte, da ansonsten die EXCEL-Datei mit den Adressen nicht als Datenbank geöffnet werden kann. Ich vermute, dass das immer auftritt, wenn Windows 10 ein Update einspielt. Ob das mit dem Nichtsenden der Mails zusammenhängt glaube ich nicht, da dies schon länger auftritt.

Code:

Sub Rechnung_Umlage_per_GMail_versenden()
'
' Makro_GMail Makro
' Makro aufgezeichnet am 16.05.2015 von XXXXXXXX
' http://www.paulsadowski.com/wsh/cdo.htm


    Dim strPfad As String ' Dateipfad der Word- und Exceldatei
    strPfad = ActiveDocument.Path & "\"

    Dim filePfad As String ' Dateipfad der Rechnungs-PDF-Datei
    filePfad = strPfad & ActiveDocument.MailMerge.DataSource.DataFields("RgJahr").Value & "\"
        
    Dim fileName As String
    fileName = "FDP-PM Rg-Nr. " & ActiveDocument.MailMerge.DataSource.DataFields("RgNr").Value & "-" _
        & ActiveDocument.MailMerge.DataSource.DataFields("RgJahr").Value & " OV-" _
        & ActiveDocument.MailMerge.DataSource.DataFields("KURZ").Value & ".pdf"
        
    Dim Anlage As String
    Anlage = filePfad & fileName
    
          
    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

    Set objMessage = CreateObject("CDO.Message")
    objMessage.Subject = "ABC-Verein | Kreisumlage Rechnung-Nr. " _
        & ActiveDocument.MailMerge.DataSource.DataFields("RgNr").Value & "/" _
        & ActiveDocument.MailMerge.DataSource.DataFields("RgJahr").Value
    objMessage.From = """Schatzmeister"" <vorname.nachname@gmail.com>"
    objMessage.To = ActiveDocument.MailMerge.DataSource.DataFields("SmEmail").Value
    objMessage.TextBody = ActiveDocument.MailMerge.DataSource.DataFields("EmailText").Value & ActiveDocument.MailMerge.DataSource.DataFields("Signatur").Value
    
    If Dir(Anlage) = "" Then
        MsgBox fileName & vbCrLf & vbCrLf & Space$(4) & "Die Email-Anlage existiert nicht."
        Exit Sub
     Else
        objMessage.AddAttachment Anlage
    End If
    

    
'==This section provides the configuration information for the remote SMTP server.


    objMessage.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2

    'Name or IP of Remote SMTP Server
    objMessage.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"

    'Type of authentication, NONE, Basic (Base64 encoded), NTLM
    objMessage.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic

    'Your UserID on the SMTP server
    objMessage.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/sendusername") = "vorname.nachname@gmail.com"

    'Your password on the SMTP server
    objMessage.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "Passwort-ABC123"
    
    'Server port (typically 25, >>>> bisher bei mir 465 <<<<)
    objMessage.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465

    'Use SSL for the connection (False or True)
    objMessage.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True

    'Connection Timeout in seconds (the maximum time CDO will try to establish a connection to the SMTP server)
    objMessage.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60

    objMessage.Configuration.Fields.Update

'==End remote SMTP server configuration section==


    objMessage.Send

    Set objMessage = Nothing
        If Err.Number <> 0 Then
            MsgBox Err.Number & vbCrLf & Err.Description
        Else
            MsgBox "Mail wurde erfolgreich versendet."
        End If

    On Error GoTo 0
      
End Sub

 

Habe das Problem lösen können. Hier habe ich den Lösungsweg gefunden:

Emails mit VBA und der CDO Bibliothek versenden

Bei der Suche in meinem Google-Konto nach Less secure Apps aktivieren bin ich darauf gestoßen, dass Google mein Konto im Dez. auf die 2-Faktor-Anmeldung umgestellt hatte. Nach Deaktivierung konnte ich wieder Emails senden.