Hallo Ralf !

Nicht auf meinem Mist gewachsen, aber man mutiert ja zum Jäger und Sammler:
//////////////
Sub SendNotesMail(ByVal MailTo As String, ByVal MailText As String, ByVal MailAnhang As String, _
ByVal MailAbsender As String, ByVal MailBetreff As String, _
Optional MailSenden = True)
'
' Versenden einer E-Mail via Lotus Notes.
'
' IN: MailTo E-Mail Adresse des Empfängers
' MailText Text der Nachricht
' MailAnhang Dateianhang (Dateiname mit Pfad)
' MailAbsender Name des Absenders (wird an den Text angeängt)
' MailBetreff Betreffzeile der E-Mail
' MailSenden True wenn Nachricht versendet werden soll,
' False wenn Nachricht als Entwurf gespeichert werden soll
'
Dim rtitem As Object
Dim EmbeddedObject As Object
Dim SessionNotes As Object, NotesDB As Object, NotesDoc As Object
Dim EmpfListe() As String
Dim EmpfCnt As Integer
Dim Pos1 As Long
'
' wenn die Betreffzeile leer ist, dann wird eine erzeugt
'
If Trim$(MailBetreff) = "" Then
MailBetreff = "Mail vom " & Date & " " & Time
End If
'
' Eigene Fehlerbehandlung
'
On Error GoTo Err_Mail_Click
'
' An die laufende Lotus Notes Session anhängen
'
Set SessionNotes = CreateObject("Notes.NOTESSESSION")
'
' Notes Datenbank-Objekt erstellen und initialisieren
'
Set NotesDB = SessionNotes.GetDatabase("", "")
NotesDB.OPENMAIL
If NotesDB.ISOPEN = False Then
MsgBox "Bitte melden Sie sich zunächst vollständig in Notes an!", vbInformation + vbOKOnly
Exit Sub
End If
'
' Empfängerliste erstellen
'
' EmpfCnt = 0
' Pos1 = InStr(MailTo, ";")
' While Pos1 > 0
' ReDim Preserv EmpfListe(EmpfCnt)
' EmpfListe(EmpfCnt) = Left(MailTo, Pos1 - 1)
' MailTo = Right(MailTo, Len(MailTo) - Pos1)
' Pos1 = InStr(MailTo, ";")
' EmpfCnt = EmpfCnt + 1
' Wend
' ReDim Preserv EmpfListe(EmpfCnt)
' EmpfListe(EmpfCnt) = MailTo
'
' Neues Notes-Dokument anlegen (Mail)
'
Set NotesDoc = NotesDB.CreateDocument
With NotesDoc
.Form = "Memo"
.Subject = MailBetreff
.sendto = "alfred.quack@beispiel-provider.de"
'.copyto = ' Kopie an
'.blindcopyto= Blindkopie an
.Body = MailText & vbCrLf & MailAbsender
'.DefaultMailSaveOption = 0
'.MailSaveOption = 0
.DeliveryReport = "B"
.Importance = "1"
'.logo = "Scania"
.SAVEMESSAGEONSEND = True ' bei True wird ein Exemplar in Notes in Gesendet gestellt
.ReturnReceipt = "1"
.Sign = "1"
'.encrypt ="0"
'.Principal = session.UserName
'.viewicon ="74"
'.from = session.UserName
'.SaveOptions = 0
'.SecureMail = ""
'.SenderTag = "F"

'''''''''''''' Dateianhang'''''''''''''''''
Dim xy
Dim mailanhang2, s As Variant

Const delim = ";"
Const embed_ATT = 1454

s = Split(MailAnhang, delim)

For xy = LBound(s) To UBound(s)
mailanhang2 = s(xy)



Set rtitem = .CreateRichTextItem(mailanhang2)
Set EmbeddedObject = rtitem.EmbedObject(embed_ATT, "", mailanhang2, mailanhang2)



Next xy
''''''''''''''''''''''''''''''''''''''''''

If MailSenden Then
.Send False
Else
.Save
End If
End With

Set SessionNotes = Nothing
Set NotesDB = Nothing
Set NotesDoc = Nothing
Set rtitem = Nothing
Set EmbeddedObject = Nothing

Exit_Mail_Click:
Exit Sub
Err_Mail_Click:
MsgBox Err.Description
Resume Exit_Mail_Click
End Sub




Und das ist ein Beispiel zum Aufruf mit vorheriger Auswahl der Attachments. Man muss natürlich das ganze so anpassen wie es einem selbst gefällt:

Zitat:Sub mailtest()
Dim Empf, MText
Dim Anlage, MAbsender, MBetreff

Dim dlgfilepicker As FileDialog, selItem As Variant

Set dlgfilepicker = Application.FileDialog(msoFileDialogOpen)

With dlgfilepicker
.AllowMultiSelect = True
.Show
For Each selItem In .SelectedItems

Anlage = Anlage & CStr(selItem) & ";"
Next selItem

End With

If Right(Anlage, 1) = ";" Then
Anlage = Left(Anlage, Len(Anlage) - 1)
End If

MAbsender = "alfred.quack@beispiel-provider.de"
MBetreff = InputBox("Geben Sie hier Ihren Betreff ein: ", "Betreff", "<Kein Betreff>")

SendNotesMail Empf, MText, Anlage, MAbsender, MBetreff, True

End Sub
////////////////////

Vielleicht hilfts ja.
Gruß
Teddy

Danke Teddy7,

Ich habe das hier und es Funktionakelt!

Private Sub Befehl9_Click()
Dim Subject As String, attachment As String, bodytext As String, saveit As Boolean
Dim ToAdressen(10) As String



    Dim Maildb As Object 'Die Datenbank
    Dim UserName As String 'Der Benutzername
    Dim MailDbName As String 'Der Datenbankname
    Dim MailDoc As Object 'Das Maildokument selbst
    Dim AttachME As Object 'Der Anhang (Richtext)
    Dim Session As Object 'Die Notes Session
    Dim EmbedObj As Object 'Ein eingebettetes Objekt (Anhang)
    Dim Recip(2) As Variant
    Dim LinkME As Object
    Dim testlink As String
     
    Subject = Text1.Value
    bodytext = Text12.Value
    ToAdressen(1) = Text1.Value
'    attachment = AppPfad & "\Links.xls"
            
    'Die Session starten
    Set Session = CreateObject("Notes.NotesSession")

 On Error GoTo Fehler:
    'Den Benutzernamen auslesen und den Dateinamen
    'der MailDB errechnen
    'Dies wird nicht überall benötigt. Auf manchen
    'Systemen kann auch ein leerer String übergeben werden
    UserName = Session.UserName
    MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
    
    'Datenbank öffnen
    Set Maildb = Session.GetDatabase("", MailDbName)
     If Maildb.IsOpen = True Then
     Else
         Maildb.OPENMAIL
     End If
     
    'Ein neues Maildokument erstellen
    Set MailDoc = Maildb.CreateDocument
    MailDoc.Form = "Memo"
    MailDoc.sendto = Me!Text1
    MailDoc.Subject = Subject
    MailDoc.body = bodytext
    MailDoc.SaveMessageOnSend = True
       
    'Eingebettete Objekte und Anhänge hinzufügen
    If attachment <> "" Then
        Set AttachME = MailDoc.CreateRichTextItem("Attachment")
        Set EmbedObj = AttachME.EmbedObject(1454, "", attachment, "Attachment")
        'MailDoc.CREATERICHTEXTITEM ("Attachment")
    End If
    
    'Senden
    MailDoc.PostedDate = Now()

If ToAdressen(1) = "" Then
    MsgBox "Please enter recipients!"
    GoTo Fehler2
Else
    MailDoc.Send 0, ToAdressen
    MsgBox "Message transmitted"
    GoTo Fehler2
End If
    
    'Aufräumen
    Set Maildb = Nothing
    Set MailDoc = Nothing
    Set AttachME = Nothing
    Set Session = Nothing
    Set EmbedObj = Nothing
        
Fehler:
    MsgBox "Please open your Lotus Notes client!"
    Exit Sub

Fehler2:
    Exit Sub
End Sub

Einen richtig schönen Tag wünsche ich dann noch.
Gruß Ralf