E-Mail senden in IBM Notes mit VBA

'#  E-Mail mit VBA in IBM NOTES senden
'|  Quellen:
'| http://www.online-excel.de/excel/singsel_vba.php?f=42
'| http://www.office-loesung.de/ftopic232699_0_0_asc.php
'| http://www-12.lotus.com/ldd/doc/lotusscript/lotusscript.nsf/1efb1287fc7c27388525642e0074f2b6/1f82ab14864680138525642e007687cb?OpenDocument
'|  Benötigt Lotus Notes Client 4.5.x oder besser
'|  Parameterinfos:
'|      Empfaenger, Kopie, Blindkopie = Eine Zeichenkette oder ein Array, dass gültige E-Mail-Adressen enthält
'|      Betreff = Eine Zeichenkette, die den Titel/das Thema der Nachricht enthält
'|      Nachtricht = Eine Zeichenkette, die den Text der E-Mail enthält
'|      Anhang =    Eine Zeichenkette, die einen oder mehrere gültige Dateipfade für die Anhänge enthält;
'|                  mehrere Dateipfade müssen mit einem Semikolon ";" getrennt werden
'|      Speichern = Gibt an, ob die E-Mail in IBM Notes im Ordner "Gesendet" gespeichert soll; optional
'|      Sofort_senden = Gibt an, ob die E-Mail in IBM Notes vor dem Senden angezeigt oder sofort gesendet werden soll
'|      Dateiname = Gibt eine alternative Maildatei an; .*.nsf; relevant, wenn man Zugang zu mehreren Maildateien besitz
'|                  bspw. persönlich Dienst-E-Mail und Filial-E-Mail etc.
'|      Die obligatorischen Parameter Betreff, Kopie, Blindkopie, Nachricht und Anhang können auch mit einem leeren STRING
'|      übergeben werden.
Public Function E_Mail_senden( _
Empfaenger As Variant, _
Kopie As Variant, _
Blindkopie As Variant, _
Betreff As String, _
Nachricht As String, _
Anhang As String, _
Optional Speichern As Boolean = True, _
Optional Sofort_senden As Boolean = False, _
Optional Dateiname As String _
) As Boolean
Dim LotusNotes As Object
Dim Maildatenbank As Object 'Die Maildatenbank
Dim MailServer As String 'Der Mailserver
Dim MailFile As String ' Die Maildatei
Dim EMail As Object 'Die E-Mail in IBM Notes
Dim Anhangobjekt As Object 'Das Anlage Richtextfile Object
Dim Session As Object 'Die Notes Session
Dim Eingebettetes_Objekt As Object 'Anhang
Dim Anhaenge() As String 'Liste mehrere Anhänge
Dim Index As Long
Dim Dateipfad As String
Dim Fehlertext As String
Dim Notesfeld As Object 'Datenfeld in IBM Notes
Dim Aktuelle_Email As Object 'Aktuelle E-Mail
'Lotus Notes Session starten
Set Session = CreateObject("Notes.NotesSession")
'Lotus-Notes-Datenbank oeffnen
MailServer = Session.GetEnvironmentString("MailServer", True)
If VBA.Len(Dateiname) = 0 Then
MailFile = Session.GetEnvironmentString("MailFile", True)
Else
MailFile = "mail/" & Dateiname
End If
Set Maildatenbank = Session.GETDATABASE(MailServer, MailFile)
'Pruefe, ob die Maildatenbank geoeffnet ist
'Provoziert im Fall, dass sie geschlossen ist, einen Fehler
If Not Maildatenbank.IsOpen Then Maildatenbank.OPENMAIL
'Neue Mail einrichten
Set EMail = Maildatenbank.CREATEDOCUMENT
'Felder füllen
Set Notesfeld = EMail.APPENDITEMVALUE("Subject", Betreff)
Set Notesfeld = EMail.APPENDITEMVALUE("SendTo", Empfaenger)
Set Notesfeld = EMail.APPENDITEMVALUE("BlindCopyTo", Blindkopie)
Set Notesfeld = EMail.APPENDITEMVALUE("CopyTo", Kopie)
'Arbeitsumgebung laden
Set LotusNotes = CreateObject("Notes.NotesUIWorkspace")
'E-Mail erstellen
LotusNotes.EDITDOCUMENT True, EMail
'Aktuell erstellte E-Mail auswählen
Set Aktuelle_Email = LotusNotes.CurrentDocument
'Nachricht einfügen
Aktuelle_Email.GotoField "Body"
Aktuelle_Email.InsertText Nachricht
'Anlagen hinzufügen
Anhaenge = VBA.Split(Anhang, ";")
For Index = LBound(Anhaenge) To UBound(Anhaenge)
Dateipfad = Anhaenge(Index)
If Dateipfad  "" And VBA.Dir(Dateipfad)  "" Then
Set Anhangobjekt = EMail.CREATERICHTEXTITEM("Attachment" & Index)
Set Eingebettetes_Objekt = _
Anhangobjekt.EMBEDOBJECT(1454, "", Dateipfad, "Attachment" & Index)
End If
Next
'Nachricht nach dem Senden speichern (oder nicht)
EMail.SAVEMESSAGEONSEND = Speichern
If Speichern = True Then EMail.Save True, True, True
'Prüfe, ob die E-Mail sofort gesenden werden soll
If Sofort_senden = True Then
'E-Mail senden
Aktuelle_Email.Send False, Empfaenger
'E-Mail schließen
Aktuelle_Email.Close
End If
'WAHR als Rueckgabewert der Funktion bestimmen
E_Mail_senden = True
End Function