das korrekte Versenden von deutsch-sprachigen Emails aus meinem eigenen selbstprogrammierten MS-Access-Praxisprogramm mit Deutschen Umlauten und der Möglichkeit auch HTML-Mails und Files (zB Befunde) zu senden (via Zoople HTML-Control) hat mich viele Stunden Recherche gekostet – selbst ChatGPT hat mir nicht geholfen (obwohl ich sonst nur noch über GPT programmiere).
die nachfolgenden Funktionen sind nur Clipboard-Functions, weil ich – wenn mein Programm einen Fehler liefert die Email eben über SHELL aussende, kann dabei aber kein file attachen
Function SendMail (ToAdress as string, optional FromAdress as string = “office@testmail.at”, optional subject as string = “testmail from xxx”, optional body as string = “testbody from xxxx”, optional HTML as boolean = false, optional BC as string = “”, optional Attachmentfile as string = “” ) As Boolean
‘ich hab da noch vieles mehr drinnen wie zB ReplyTo, Organisation, Sendername, …… dass ist bei mir alles optional mit Texten vorbelegt ist, ggf. die funktion in ChatGPT für eigenen Zwecke optimieren lassen
Const c = “http://schemas.microsoft.com/cdo/configuration/”
Const cdoSendUsingPickup = 1
Const cdoSendUsingPort = 2
Const cdoAnonymous = 0
‘ Use basic (clear-text) authentication.
Const cdoBasic = 1
‘ Use NTLM authentication
Const cdoNTLM = 2 ‘NTLM
Dim ObjMessage As New CDO.Message, iConf As New CDO.Configuration, gO As Boolean
On Error GoTo x
If ToAddress = “” Then Exit Function
SendMail = True ‘standard-Rückgabewert setzeh
ToAddress = replace(ToAddress, “@gmail”, “@googlemail”)
‘–> gmail ist wichtig, weil sonst die emails vom empfänger zurückgewiesen werden, habe sehr lange gesucht um das rauszufinden
Set ObjMessage = CreateObject(“CDO.Message”)
Set iConf = CreateObject(“CDO.Configuration”)
With ObjMessage
.Subject = Subject
.From = Sender + ” <” + FromAddress + “>”
.To = ToAddress
‘.cc = CC_Adressen ‘brauchen wir nicht
‘body = EncodeGermanCharacters(body) –> funktioniert nicht, genauso nicht wie EncodeBase64 mit einer entsprechenden EncoderFunktion
.BodyPart.Charset = “iso-8859-1” ‘das war das geheimnis um saubere deutsche Umlaute zu bekommen, diesen Teil hab ich in den 50 varianten die irgendwo im Internet publiziert werden nie gesehen,
‘gefunden in https://www.emde-it-loesungen.de/techtalk/microsoft-access/e-mails-versenden-mit-cdo.html
If Not isHTML Then
.TextBody = Body
Else
‘bei HTML wird automatisch MIME auf mehrere Mails bzw. geteilte mails umgestellt –> das wird aber unten wieder korrigiert
If Not InStr(Body, “<body>”) Then Body = “<body>” + Body + “</body>”
If Not InStr(Body, “<html>”) Then Body = “<html>” + Body + “</html>”
‘Debug.Print Body
.HTMLBody = Body
‘.TextBody = “” ‘Nothing – nicht notwendig
End If
‘das sind jetzt spezielle Erweiterungen für mich um sicher immer über das Sekretariat rauszuschreiben
If Organization = “xxxx” Then Organization = “yyyyy”
If Sender = “xxxx” Then Sender = “yyyyyy”
.Sender = FromAddress
.Organization = Organization
.ReplyTo = ReplyTo
.BCC = BC
‘.cc = “xxxx”
Set .Configuration = iConf
End With
If Attachedfile <> “” Then
If Not CheckFileExists(Attachedfile) Then
MsgBox “der übergebene Dateiname zeigt ins Nirgendwo: ” + vbCrLf + Attachedfile
Exit Function
End If
ObjMessage.AddAttachment Attachedfile ‘sMailAttachment
‘Debug.Print ObjMessage.BodyPart(0).ContentMediaType
‘Debug.Print ObjMessage.BodyPart(1).ContentMediaType
‘source: https://codingislove.com/list-mime-types-2016/
‘If InStr(AttachedFile, “.pdf”) Then ObjMessage.Attachments.item(1).ContentMediaType = “application/pdf”
‘If InStr(AttachedFile, “.jp”) Then ObjMessage.Attachments.item(1).ContentMediaType = “image/pjpeg”
‘If InStr(AttachedFile, “.pdf”) Then ‘
End If ‘wo kommt das her ? ev. wegstreicen
‘https://www.ionos.de/hilfe/e-mail/ssl-verschluesselung-fuer-e-mail/verschluesselung-ssltls-in-einem-e-mail-programm-aktivieren/
‘arbeitet jetzt über TSL 1.2 seit 16.2.2023
With ObjMessage.Configuration.Fields
.item(c + “sendpassword”) = Password
‘.item(c + “smtpusessl”) = False
.item(c + “smtpusessl”) = True ‘ um gleich initial TSL verschlüsselt zu agieren
.item(c + “sendusername”) = FromAddress
.item(c + “sendusing”) = cdoSendUsingPort
.item(c + “smtpauthenticate”) = cdoBasic ‘cdoNTLM ‘
.item(c + “smtpserver”) = MailServer ‘wurde als optional-Variable übergeben bzw vorbesetzt, nimm deinen eigenen mailserver wie zB smtp.ionos.de
.item(c + “smtpserverport”) = 25
If InStr(MailServer, “ionos”) <> 0 Then
.item(c + “smtpserverport”) = 465 ‘–> fehler Meldung ohne pusessl, IONOS braucht seit 2023 pusessl als true –> für IONOS war der notwendig, nicht für Domain-Technik
End If
‘.item(c + “smtpserverport”) = 587 ‘–> fehler Meldung bei Ionos und auch bei Domain-Technik, obwohl im Handbuch von Domain-Technik dieser Port angegeben wird
‘ Setzen des Charset auf UTF-8 –> bringt aber nix für Deutsche UMLAUTE
‘ war der Vorschlag von ChatGPT um Umlaute richtig anzuzeigen
.item(c + “encoding”) = “base64” ‘Für UTF-8 Kodierung – laut ChatGPT – stört komischerweise nicht
.item(c + “charset”) = “UTF-8”
‘ Setzen Sie den ContentType auf text/plain und Charset auf utf-8
.item(c & “content-type”) = “text/plain;charset=utf-8”
‘obwohl text/plain gesetzt wird funktioniert HTML-Body trotzdem ???
.item(c & “content-transfer-encoding”) = “base64”
‘auch von ChatGPT für Umlaute vorgeschlagen, funktioniert auch nicht – stört aber nicht
.Update
End With
ObjMessage.Send
If Attachedfile <> “” Then Delay (1000) Else Delay (200)
‘sonst Fehlermeldung in der nachfolgend durchlaufenen RenameFile Procedure, wo ein gesendeter Befund in “Befund_emailed_am_xxx-yyy-zzz.pdf” umbenannt wird
Set ObjMessage = Nothing
Set iConf = Nothing
Exit Function
x:
MsgBox “error ” + CStr(err.Number) + ” in Fn SendMail ” + err.Description
‘Debug-Texte ins Direktfenster ausgeben in VBE
Debug.Print vbCrCrLF
Debug.Print ToAddress
Debug.Print Attachedfile
Debug.Print Subject
Debug.Print vbCrLf + Body + vbCrCrLF
‘Fehler – desswegen die Email über Shell senden, leider funktioniert das mit dem Attachedfile nicht
Call SetClipboardHTML(Body)
MsgBox “der HTML-Text wurde ins Clipboard kopiert”
Call ShellMail(ToAddress, Subject, Attachedfile)
SendMail = False
End Function
‘schickt die Email aus über Shell aber kann kein Attached file aussenden, nur für mich um zu wissen welches File ich noch nachzusenden habe
Function ShellMail(ToAdress As String, Optional Subject As String = “”, Optional Body As String = “”, Optional Attachedfile As String = “”)
Dim s As String
ToAdress = replace(ToAdress, “@gmail”, “@googlemail”)
If ToAdress & “” <> “” And InStr(ToAdress, “@”) <> 0 Then
If Attachedfile <> “” Then Body = Body + ” ” + Attachedfile
s = “mailto:” + ToAdress + “?subject=” + Subject & replace(“&body=” + Body, ” “, “%20”)
Call ShellExecute(0&, “Open”, s, “”, “”, 1)
End If
End Function
‘und noch ein paar hilfsfunktionen
Public Function SetClipboardHTML(HTML As String, Optional SourceURL As String = “https://www.ganzemedizin.at”)
Dim s As String, i As Long, j As Long, ss As String
Const c = “Version:0.9” + vbCrLf + “StartHTML:0000000541” + vbCrLf + “EndHTML:0000007048” + vbCrLf + “StartFragment:0000000577” + vbCrLf + “EndFragment:0000007012” + “SourceURL:dddd”
s = “Version:0.9” + vbCrLf + “StartHTML:§AAA§” + vbCrLf + “EndHTML:§BBB§” + vbCrLf
s = s + “StartFragment:§CCC§” + vbCrLf + “EndFragment:§DDD§” + vbCrLf + “SourceURL:§EEE§” + vbCrLf
s = s + “<html>” + vbCrLf + “<body>” + vbCrLf + “<!–StartFragment–>”
s = s + “§FFF§” + “<!–EndFragment–>” + vbCrLf + “</body>” + vbCrLf + “</html>”
s = replace(s, “§EEE§”, SourceURL)
s = replace(s, “§FFF§”, HTML)
i = InStr(s, “<html>”) – 1
ss = Format(i, “0000000000”)
s = replace(s, “§AAA§”, ss)
i = InStr(s, “</html>”) + 7
ss = Format(i, “0000000000”)
s = replace(s, “§BBB§”, ss)
i = InStr(s, “<!–StartFragment–>”)
ss = Format(i, “0000000000”)
s = replace(s, “§CCC§”, ss)
i = InStr(s, “<!–EndFragment–>”) + Len(“<!–EndFragment–>”)
ss = Format(i, “0000000000”)
s = replace(s, “§DDD§”, ss)
Debug.Print s
Call SetClipboardData(s, False, True)
End Function
Function SetClipboardData(strText As String, Optional RTF As Boolean = False, Optional HTML As Boolean = False) As Boolean
‘ Comments : Writes the supplied string to the clipboard
‘ Parameters: strText – text to write
‘ Returns : True if successful, False otherwise
‘
Dim lngHoldMem As Long
Dim lngGlobalMem As Long
Dim lngClipMem As Long
Dim lngTmp As Long
On Error GoTo SetClipboardData_ERR
If RTF Then
Call RegistRTF
End If
If HTML Then
Call RegistHTML
End If
‘ Allocate moveable global memory.
lngHoldMem = TSB_API_GlobalAlloc(GHND, Len(strText) + 1)
‘ Lock the block to get a far pointer to this memory.
lngGlobalMem = TSB_API_GlobalLock(lngHoldMem)
‘ Copy the string to this global memory.
lngGlobalMem = TSB_API_lstrCopy(lngGlobalMem, strText)
‘ Unlock the memory.
If TSB_API_GlobalUnlock(lngHoldMem) = 0 Then
‘ Open the Clipboard to copy data to.
If TSB_API_OpenClipboard(0&) <> 0 Then
‘ Clear the Clipboard.
lngTmp = TSB_API_EmptyClipBoard()
‘ Copy the data to the Clipboard.
‘ lngClipMem = TSB_API_SetClipboardData(CF_RTFTEXT, lngHoldMem)
If RTF Then
lngClipMem = TSB_API_SetClipboardData(cfRTF, lngHoldMem)
Else
If HTML Then
lngClipMem = TSB_API_SetClipboardData(cfHTML, lngHoldMem)
Else
lngClipMem = TSB_API_SetClipboardData(CF_TEXT, lngHoldMem)
End If
End If
lngTmp = TSB_API_CloseClipboard()
End If
End If
SetClipboardData = True
SetClipboardData_EXIT:
Exit Function
SetClipboardData_ERR:
SetClipboardData = False
Resume SetClipboardData_EXIT
End Function
Function RegistHTML() As Long
On Error GoTo er
cfHTML = RegisterClipboardFormat(CF_HTML)
er:
End Function
Function RegistRTF() As Long
On Error GoTo er
cfRTF = RegisterClipboardFormat(CF_RTF)
er:
End Function
‘nachfolgend gehört als API-Funktion ganz oben deklariert
‘Private Declare Function RegisterClipboardFormat Lib “user32” Alias _
“RegisterClipboardFormatA” (ByVal lpString As String) As Long
Public Declare Function TSB_API_OpenClipboard Lib “user32” Alias “OpenClipboard” _
(ByVal hWnd As Long) _
As Long
Public Declare Function RegisterClipboardFormat Lib “user32” _
Alias “RegisterClipboardFormatA” (ByVal lpString As String) _
As Long
Public Declare Function TSB_API_GetClipboardData Lib “user32” Alias “GetClipboardData” _
(ByVal wFormat As Long) _
As Long
Public Declare Function TSB_API_GlobalAlloc Lib “kernel32” Alias “GlobalAlloc” _
(ByVal wFlags As Long, ByVal dwBytes As Long) _
As Long
Public Declare Function TSB_API_GlobalLock Lib “kernel32” Alias “GlobalLock” _
(ByVal hMem As Long) _
As Long
Public Declare Function TSB_API_lstrCopy Lib “kernel32” Alias “lstrcpyA” _
(ByVal lpString1 As Any, ByVal lpString2 As Any) _
As Long
Public Declare Function TSB_API_GlobalUnlock Lib “kernel32” Alias “GlobalUnlock” _
(ByVal hMem As Long) _
As Long
Public Declare Function TSB_API_CloseClipboard Lib “user32” Alias “CloseClipboard” _
() _
As Long
Public Declare Function TSB_API_SetClipboardData Lib “user32” Alias “SetClipboardData” _
(ByVal wFormat As Long, ByVal hMem As Long) _
As Long
Public Declare Function TSB_API_EmptyClipBoard Lib “user32” Alias “EmptyClipboard” _
() _
As Long
Private Const CF_RTF = “Rich Text Format”
Private Const CF_HTML = “HTML Format”
‘https://dbwiki.net/wiki/VBA_Tipp:_Anwendung_mit_ShellExecute_starten#Dokument_.C3.B6ffnen
‘Konstanten für den Parameter “nshowcmd”
Public Const SW_HIDE = 0 ‘Alternative: vbHide, Fenster versteckt öffnen
Public Const SW_MAXIMIZE = 3 ‘Alternative: vbMaximizedFocus, Fenster maximiert öffnen
Public Const SW_MINIMIZE = 6 ‘Alternative: vbMinimizedNoFocus, Fenster minimiert öffnen
Public Const SW_RESTORE = 9
Public Const SW_SHOW = 5
Public Const SW_SHOWDEFAULT = 10
Public Const SW_SHOWMAXIMIZED = 3
Public Const SW_SHOWMINIMIZED = 2 ‘Alternative: vbMinimizedFocus
Public Const SW_SHOWMINNOACTIVE = 7
Public Const SW_SHOWNA = 8
Public Const SW_SHOWNOACTIVATE = 4 ‘Alternative: vbNormalNoFocus
Public Const SW_SHOWNORMAL = 1 ‘Alternative: vbNormalFocus
‘Quelle: www.dbwiki.net oder www.dbwiki.de
Public Declare Function ShellExecute Lib “shell32.dll” Alias “ShellExecuteA” ( _
ByVal hWnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long _
) As Long
