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 nutze MS Office 2010 Professional auf einem Windows10-Rechner. 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.
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
|