VBA Tipp: E-Mail ohne E-Mailprogramm versenden (CDO)

Aus DBWiki
Wechseln zu: Navigation, Suche

Aufgabenstellung

  • Ich möchte E-Mails aus Access versenden, ohne dass ein E-Mailprogramm (E-Mail-Client) auf dem Rechner installiert ist.
  • Der Versand erfolgt über die CDO (Collaboration Data Objects).

Lösung

Das geht mit der folgenden Funktion, die in einem globalen Modul hinterlegt wird.

Public Function MailversandCDO(ByVal Postausgangsserver As String, _
                               ByVal Benutzername As String, _
                               ByVal Mailpasswort As String, _
                               ByVal Absender As String, _
                               ByVal Empfänger As String, _
                               ByVal Betreff As String, _
                               ByVal Nachricht As String, _
                               Optional ByVal HTML As Boolean = False, _
                               Optional ByVal PfadAnhang As String = vbNullString, _
                               Optional ByVal OhneSSL As Boolean = False _
                               ) As Boolean
 
 'Late Binding: Kein Verweis auf "Microsoft CDO for Windows 2000 Library" notwendig
 'Pfad zur Bibliothek: 32bit: C:\Windows\System32\cdosys.dll, 64bit: C:\Windows\SysWOW64\cdosys.dll
 'Quelle: http://www.dbwiki.net/
 
 Dim Mail As Object     'CDO.Message
 Dim CC As Object       'CDO.Configuration
 Dim Schema As String
 
 Const cdoSendUsingPort = 2
 Const cdoBasic = 1
 
 On Error GoTo Err_MailversandCDO
 
 'Sanduhr ein
 DoCmd.Hourglass True
 
 Set Mail = CreateObject("CDO.Message")
 Set CC = CreateObject("CDO.Configuration")
 Schema = "http://schemas.microsoft.com/cdo/configuration/"
 
 '---------------------------------------------------------
 'Konfiguration Mail-Server und Login
 
 With CC.Fields
 
   'Versandart: Über das Netzwerk
   .Item(Schema & "sendusing").Value = cdoSendUsingPort
 
   'Postausgangsserver (SMTP = Simple Mail Transfer Protocol)
   .Item(Schema & "smtpserver").Value = Postausgangsserver
 
   If OhneSSL = True Then
     'ohne SSL-Verschlüsselung, Port 25 (alternativ 587)
     .Item(Schema & "smtpserverport").Value = 25
   Else
     'mit SSL-Verschlüsselung, Port 465
     .Item(Schema & "smtpusessl").Value = "true"
     .Item(Schema & "smtpserverport").Value = 465
   End If
 
   'Server erfordert Authentifizierung, mit Benutzernamen und Mail-Passwort
   .Item(Schema & "smtpauthenticate").Value = cdoBasic
   .Item(Schema & "sendusername").Value = Benutzername
   .Item(Schema & "sendpassword").Value = Mailpasswort
 
   .Update
 
 End With
 
 
 '---------------------------------------------------------
 'Mail-Versand
 
 With Mail
 
   Set .Configuration = CC
 
   'Empfänger E-Mail-Adresse
   .To = Empfänger
 
   'Absender E-Mail-Adresse
   .From = Absender
 
   'Betreff
   .Subject = Betreff
 
   'Nachricht im HTML-Format
   If HTML = True Then
     .HTMLBody = Nachricht
 
   'Nachricht im Plaintext-Format
   Else
     .TextBody = Nachricht
   End If
 
   'Anhang
   If Not PfadAnhang = vbNullString Then
     .AddAttachment PfadAnhang
   End If
 
   'Mail senden
   .Send
 
 End With
 '---------------------------------------------------------
 
 MailversandCDO = True
 
Exit_MailversandCDO:
 Set CC = Nothing
 Set Mail = Nothing
 'Sanduhr aus
 DoCmd.Hourglass False
 Exit Function
 
Err_MailversandCDO:
 MailversandCDO = False
 'Fehlermeldung
 MsgBox "Laufzeitfehler '" & Err.Number & "':" & vbCrLf & vbLf & Err.Description
 Resume Exit_MailversandCDO
 
End Function

Aufruf

 Dim strPostausgangsserver   As String
 Dim strBenutzername         As String
 Dim strMailpasswort         As String
 Dim strAbsender             As String
 Dim strEmpfänger            As String
 Dim strBetreff              As String
 Dim strNachricht            As String
 Dim strHTMLNachricht        As String
 Dim strPfadAnhang           As String
 
 'Postausgangsserver mit SSL-Verschlüsselung: Beispiel für T-Online
 strPostausgangsserver = "securesmtp.t-online.de"
 
 'Benutzer
 strBenutzername = "max.mustermann@t-online.de"
 
 'Passwort
 strMailpasswort = "geheim"
 
 'Absender-Adresse entweder mit oder ohne Vor- und Nachnamen
 strAbsender = "Max Mustermann <max.mustermann@t-online.de>"
 'strAbsender = "max.mustermann@t-online.de"
 
 'Empfänger-Mailadresse, mehrere Empfänger mit ";" trennen
 strEmpfänger = "hans.mustermann@t-online.de"
 'strEmpfänger = "hans.mustermann@t-online.de; fritz.mustermann@t-online.de"
 
 'Betreff, auch Umlaute möglich
 strBetreff = "Ihre Bestellung"
 
 'Anhang, Pfad zu einer Datei (optionaler Parameter)
 strPfadAnhang = "D:\Eigene Dateien\Rechnung.pdf"
 
 'Muster für normale Textnachricht
 strNachricht = "Sehr geehrter Kunde, " & vbCrLf & vbCrLf & _
                "hiermit bestätigen wir Ihre Bestellung." & vbCrLf & vbCrLf & _
                "Viele Grüße"
 
 'Muster für HTML-Textnachricht (ggf. mit einem HTML-Editor erzeugen)
 strHTMLNachricht = "<html>" & _
                    "<p>Sehr geehrter Kunde, <br /><br />" & _
                    "anbei finden Sie die Rechnung zur Ihrer Bestellung.<br /><br />" & _
                    "Viele Grüße</p>" & _
                    "</html>"
 
'--------------------------------------
 'Versand-Beispiele:
 
 'Beispiel 1: Mail versenden, Plain-Textformat (= normaler Text)
 If MailversandCDO(strPostausgangsserver, strBenutzername, strMailpasswort, _
                   strAbsender, strEmpfänger, strBetreff, strNachricht) = True Then
   MsgBox "Das Mail wurde versandt"
 Else
   MsgBox "Das Mail wurde nicht versandt"
 End If
 
 'Beispiel 2: Mail mit Anhang versenden, HTML-Textformat
 If MailversandCDO(strPostausgangsserver, strBenutzername, strMailpasswort, _
                   strAbsender, strEmpfänger, strBetreff, strHTMLNachricht, True, strPfadAnhang) = True Then
   MsgBox "Mail wurde versandt"
 Else
   MsgBox "Mail wurde nicht versandt"
 End If

Hinweise:

  • Während des Mailversands wird der Cursor als Sanduhr angezeigt.
  • Die Dauer des Mailversands ist von der Größe des Anhangs abhängig.


Web-Links

Der Code wurde in Access 2010 erstellt, und unter Windows 7 und Windows 10 getestet.