Es funktioniert :)so und anbei der gesamte Code, um mehrere Empfänger mit einer persönlichen Anrede anschreiben zu können, + Signatur und + zwei möglichen Anhängen
Option Explicit
Sub CommandButton1_Click()
If MsgBox("Sollen die E-Mail(s) gesendet werden?", vbQuestion + vbYesNo, _
"Löschen bestätigen") = vbYes Then
Dim sText As String, sEmpfang As String, sBetrifft As String
Dim session As Object, db As Object, doc As Object, rtobject As Object
Dim rtitem As Object, sKopie As String
Dim AttachMe As Object, DerAnhang As Object
Dim user As String, server As String
Dim mailfile As String, sBlindKopie As String
Dim vAn As Variant, vCopy As Variant
Dim vBlind As Variant, sAnhang As String, sAnhang2 As String, sAnhang3 As String
Dim profile As Object
Dim RTSig As Object
Dim i As Long
Dim sAnrede As Variant
Dim sVorname As Variant
Dim sNachname As Variant
Dim tempAnrede As Variant
On Error GoTo Fehler
'*************************************************************************************************************
For i = 12 To cells(Rows.Count, 9).End(xlUp).Row ' von Zeile 12 in Spalte 9 bis zur letzten beschriebenen Zeile in Spalte 9
vAn = cells(i, 9) ' e-Mail an alle Empfänger, die ab Zeile 12 in Spalte 9 stehen
sBetrifft = Range("b3") ' die Betreffzeile der E-Mail steht in Zelle "B3"
sAnrede = Range("e" & i) ' nehme Anrede aus Spalte e
Select Case (sAnrede)
Case "Herr": 'Im Fall, dass Anrede "Herr" in Spalte e, dann schreibe "Sehr geehrter Herr"
tempAnrede = "Sehr geehrter Herr"
Case "Frau":
tempAnrede = "Sehr geehrte Frau" 'Im Fall, dass Anrede "Frau" in Spalte e, dann schreibe "Sehr geehrte Frau"
Case "Sehr geehrte Damen und Herren":
tempAnrede = "Sehr geehrte Damen und Herren"
Case "Dear":
tempAnrede = "Dear" 'Im Fall, dass Anrede "Dear" in Spalte e, dann schreibe "Dear"
End Select
sVorname = Range("f" & i) 'Nehme den Vorname aus Spalte f
sNachname = Range("g" & i) 'Nehme den Vorname aus Spalte g
If Sheets("Tabelle1").Range("h" & i).Value = "Deutsch" Then ' wenn in Spalte h ab Zeile 12 als Sprache "Deutsch" eingetragen ist, dann
sText = tempAnrede & " " & sNachname & "," & Chr(10) & Chr(10) & Range("B4") & Chr(10) ' nehme die gewählte Anrede + Nachnamen + den Text aus Zelle "B4"
Else
sText = tempAnrede & " " & sVorname & "," & Chr(10) & Chr(10) & Range("D4") & Chr(10) 'sonst nehme Anrede + Vorname + Text aus Zelle "D4"
End If
sKopie = Range("d3") ' Kopie an E-Mail Empfänger aus Zelle "D3", bei mehreren, Einträge durch " ; " getrennt
sBlindKopie = " " ' Einträge durch " ; " getrennt
sAnhang = Range("b6") ' Link zum Anhang1 in Zelle "B6"
sAnhang2 = Range("b7") ' Link zum Anhang2 in Zelle "B7"
If Len(sKopie) > 0 Then vCopy = Split(sKopie, " ; ") 'cc Array
If Len(sBlindKopie) > 0 Then vBlind = Split(sBlindKopie, " ; ") 'bcc Array
Set session = CreateObject("Notes.NotesSession") 'Notes muss gestartet sein
user = session.UserName
server = session.GetEnvironmentString("MailServer", True)
mailfile = session.GetEnvironmentString("MailFile", True)
Set db = session.getdatabase(server, mailfile)
Set doc = db.createdocument()
doc.form = "Memo"
doc.sendTo = vAn 'an array
If Len(sKopie) > 0 Then doc.copyto = vCopy 'cc Array
If Len(sBlindKopie) > 0 Then doc.blindcopyto = vBlind 'bcc Array
doc.Subject = sBetrifft ' Bereff E-Mail aus sBetrifft
Set profile = db.GetProfileDocument("CalendarProfile") ' Nehme das LN Profile aus dem "Calender Profile"
Set RTSig = profile.GetFirstItem("Signature_Rich") '
Set rtitem = doc.CreateRichTextItem("body")
Call rtitem.AppendText(sText)
Call rtitem.AddNewLine(2) ' füge nach dem text noch zwei leere Zeilen ein
Call rtitem.AppendRTItem(RTSig) ' Kopiere RTSig in den Body
doc.SAVEMESSAGEONSEND = True
doc.PostedDate = Now
If sAnhang <> "" Then
Call rtitem.EMBEDOBJECT(1454, "", sAnhang) 'hänge Anhang an
Call rtitem.EMBEDOBJECT(1454, "", sAnhang2) 'hänge Anhang2 an
End If
rtitem.saveToDisk = True
'***********************************************************************************************************************************
Call doc.Save(True, False)
Call doc.Send(False)
Next i
Aufraeumen:
On Error GoTo Fehler
Set rtitem = Nothing
Set AttachMe = Nothing
Set DerAnhang = Nothing
Set db = Nothing
Set doc = Nothing
Set session = Nothing
Exit Sub
Fehler:
MsgBox "Fehler in Sub Fehler 0 Erste Division" & vbCrLf _
& "Fehlernummer: " & Err.Number & _
vbCrLf & "Fehlerbeschreibung: " & Err.Description
End If
End Sub
Noch einmal vielen Dank für eure Hilfe
