Aktuelle Excel Vorlage per mail (Lotus) versenden

Hallo,
eine aktuelle Excel Vorlage (P2) soll per Mail als Anlage mit verschickt werden.
Es klappt alles (mail Empfänger wird eingetragen, betreff, Text 1-4 und Vorlage wird auch gespeichert)
nur die Excel Vorlage ist nicht als Anlage vorhanden, Mail wird automatisch ohne Anlage verschickt !
Wer kann dewn Fehler im Code finden ?
Gruss Jürgen

Sub Mail_Weg()
Dim Ad$, K$, B$, t$, T1$, T2$, T3$, T4$, P1$, P2$, Text
Ad = Range(„O18“).Value
B = „Auftrag zur Schadenbesichtigung (“ & Range(„D6“).Value & „)“
T1 = "Sehr geehrte® Frau/Herr " & Range(„O12“).Value & ", "
T2 = „hiermit erhalten Sie einen Neuauftrag zur Schadenbesichtigung.“
T3 = „Bitte nach dem Ausfüllen den Hinweis unter Taskforce-Mitarbeiter: (Info Rücksendung) beachten !“
T4 = "Mit freundlichen Grüßen " & Range(„D8“).Value
P1 = „C:\Users\gunag\Documents\test“
P2 = Range(„D6“) & „_Beauftragung_TASKF.xlsm“

MailErstellen Ad, K, B, T1, T2, T3, T4, P1, P2
Datensatzerstellen

End Sub
Sub MailErstellen(Adr$, Kopie$, Betrifft$, Text$, Text2$, Text3$, Text4$, Pfad$, Pfad2$)
Dim sText As String, sText1 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, AttachMe As Object, AttachMe2 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, sAnhang2 As String

'*** Mail erstellen
        'sText = T1 & T2 & T3 & T4
        sText = Text & vbCrLf & vbCrLf & Text2 & vbCrLf & Text3 & vbCrLf & vbCrLf & Text4
        sText = Replace(sText, vbCrLf, Chr(10)) ' Zeilenumbrüche ändern
    '    sEmpfang = "Email1 ; Email2 " ' Einträge durch " ; " getrennt
        sEmpfang = Adr ' Einträge durch " ; " getrennt
        sBetrifft = Betrifft ' die Betreffzeile
    '    sKopie = Kopie
    '    sKopie = "[email protected]" ' Einträge durch " ; " getrennt
    '    sBlindKopie = "Email1 ; Email2 " ' Einträge durch " ; " getrennt
        vAn = Split(sEmpfang, " ; ") ' Empfänger Array
        sAnhang = Range("D6") & "_Beauftragung_TASKF.xlsm"
        sAnhang2 = Range("D6") & "_Beauftragung_TASKF.xlsm"
        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
        Set rtitem = doc.CREATERICHTEXTITEM("body")
        Call rtitem.APPENDTEXT(sText)
        doc.SaveMessageOnSend = True
        doc.ReplaceItemValue("ReturnReceipt", "1") = True
        doc.PostedDate = Now
        
         '*****************Datei speichern, schliessen und versenden*************

Set wkbMappe = Workbooks(Range(„D6“) & „_Beauftragung_TASKF.xlsm“)
If Not wkbMappe Is Nothing Then wkbMappe.Save
Application.Quit
’ **********************************************************************

        If sAnhang <> "" Then
            Set AttachMe = doc.CREATERICHTEXTITEM(ActiveWorkbook.Path & "\" & ActiveWorkbook.Name)
            Set DerAnhang = AttachMe.EMBEDOBJECT(1454, "", ActiveWorkbook.Path & "\" & ActiveWorkbook.Name)
        End If
        
        '*******************************
        Call doc.Send(False)

Aufraeumen:
On Error Resume Next
Set rtitem = Nothing
Set AttachMe = Nothing
Set DerAnhang = Nothing
Set db = Nothing
Set doc = Nothing
Set session = Nothing
Exit Sub
Fehler:
Resume Aufraeumen
End Sub

Hallo,

Meine Lotus Notes Zeit liegt schon etwas zurück, kann sein, dass das zweite Argument beim EmbedObject korrigiert werden muss:

Dim attachment

attachment = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
If sAnhang <> "" Then ' sollte eigentlich attachment prüfen m. M. nach
        Set AttachMe = doc.CREATERICHTEXTITEM(attachment)
        Set DerAnhang = AttachMe.EMBEDOBJECT(1454, attachment, attachment)
    End If

Sicher bin ich mir da nicht mehr und mangels Lotus Notes kann ich es auch nicht mehr ausprobieren. Hoffe aber, dass es das war.

Gruß
tastatürchen