Persönliche Anrede bei E-Mails

Sub lotus()
Dim sText As Variant, sEmpfang As Variant, sBetrifft As String
Dim session As Object, db As Object, doc As Object, rtobject, ws As Object
Dim x As Integer, y As Integer, Msg As Integer
Dim sKopie As String, AttachMe As Object, DerAnhang As Object
Dim user As String, server As String, mailfile As String, sBlindKopie As String
Dim vAn As Variant, vCopy As Variant, vBlind As Variant, sAnhang As String
Dim sAnrede As Variant
Dim sVorname As Variant
Dim sNachname As Variant
Dim tempAnrede As Variant
For i = 12 To Cells(Rows.Count, 9).End(xlUp).Row
If Cells(i, 10)  "ja" Then ' keine E-Mail, wenn "ja" in Spalte "geantwortet"
vAn = vAn & "; " & Cells(i, 9)
End If
Next i
vAn = Mid(vAn, 3)
sAnrede = Range("e12") 'Anrede in Spalte e
If sAnrede = "Herr" Then 'wenn in Spalte "e" Anrede "Herr" dann
tempAnrede = "Sehr geehrter Herr"
ElseIf sAnrede = "Frau" Then 'wenn in Spalte "e" Anrede "Frau" dann
tempAnrede = "Sehr geehrte Frau"
ElseIf sAnrede = "Dear" Then 'wenn in Spalte "e" Anrede "Dear" dann
tempAnrede = "Dear"
End If
sVorname = Range("f12") 'Vorname in Spalte f
sNachname = Range("g12") 'Nachname in Spalte g
If Sheets("Tabelle1").Range("h12").Value = "Deutsch" Then 'wenn in Spalte "h" "Deutsch" dann
sText = tempAnrede & " " & sNachname & "," & vbCrLf & vbCrLf & Range("B4") & vbCrLf ' Text  _
aus Zelle B4
sText = Replace(sText, vbCrLf, Chr(10)) ' Zeilenumbrüche ändern
Else
sText = tempAnrede & " " & sVorname & "," & vbCrLf & vbCrLf & Range("D4") & vbCrLf ' wenn  _
nicht, dann Text aus Zelle B4
sText = Replace(sText, vbCrLf, Chr(10)) ' Zeilenumbrüche ändern
End If
sBetrifft = Range("B3") ' Überschrift in Zelle b3
'Wenn du keine Kopie od Blindkopie versenden willst, dann grad weglassen
sKopie = Range("D3") ' Einträge durch " ; " getrennt Kopietest@gmx.de
'sBlindKopie = "Email1 ; Email2 " ' Einträge durch " ; " getrennt
sAnhang = Range("B6") ' Link aus Zelle b6
sAnhang2 = Range("B7") ' Link aus Zelle b7
sAnhang3 = Range("B8") ' Link aus Zelle b8
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 ' die Betreffzeile
doc.SAVEMESSAGEONSEND = True
doc.PostedDate = Now
'Die Zeilen mit dem Anhang nach hier oben verschieben, ist wichtig die Reihenfolge
If sAnhang  "" Then
Set AttachMe = doc.CREATERICHTEXTITEM("Attachment")
Set DerAnhang = AttachMe.EMBEDOBJECT(1454, "", sAnhang)
Set DerAnhang2 = AttachMe.EMBEDOBJECT(1454, "", sAnhang2)
Set DerAnhang3 = AttachMe.EMBEDOBJECT(1454, "", sAnhang3) ',"Attachment" wird nicht benö _
tigt
End If
Set ws = CreateObject("Notes.NotesUIWorkspace") ' **durch das öffnen des Dokumentes durch  _
NotesUIWorkspace**
Call ws.EDITDOCUMENT(True, doc)             ' **erreicht man das die eingestellte Signatur  _
aus den    **
Set doc = ws.CURRENTDOCUMENT                      ' **Lotus Notes Optionen eingefügt wird    _
Call doc.GOTOFIELD("Body")
Call doc.insertText(sText)
Call doc.Send(True)
Call doc.Close               'Schliesst das gesendete Formular
Call doc.Save(True, True)
Aufraeumen:
On Error Resume Next
Set AttachMe = Nothing
Set DerAnhang = Nothing
Set ws = Nothing
Set doc = Nothing
Set db = Nothing
Set session = Nothing
Exit Sub
Fehler:
Resume Aufraeumen
End Sub