Lotusmail über Mailpool per VBA
21.03.2017 10:36:39
r
Über folgenden Code ist der Versand über die eigene Mailadresse möglich:
Option Explicit
Sub Versand()
Dim sText As String, sEmpfang As String, sBetrifft As String
Dim session As Object, db As Object, doc As Object, rtobject, ws As Object
Dim sKopie As String, AttachMe As Object, DerAnhang As Object, 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, e As String, l _
_
_
_
_
As String
Dim MailDoc As Object
Dim n As String
Dim c As String
Dim u As String
On Error GoTo Fehler
sText = "Guten Tag"" ' Testtext
sText = Replace(sText, vbCrLf, Chr(10)) ' Zeilenumbrüche ändern
sEmpfang = "" ' Einträge durch " ; " getrennt
sBetrifft = ""
sKopie = ""
'sBlindKopie = "Email1 ; Email2 "
vAn = Split(sEmpfang, " ; ") ' Empfänger Array
sAnhang = "U:\test.pdf" '
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 '
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)
End If
Set ws = CreateObject("Notes.NotesUIWorkspace") '
Call ws.EDITDOCUMENT(True, doc) '
Set doc = ws.CURRENTDOCUMENT '
Call doc.GOTOFIELD("Body")
Call doc.INSERTTEXT(sText)
Dim Workspace As Object
Set Workspace = CreateObject("Notes.NOTESUIWORKSPACE")
'Call Workspace.EDITDOCUMENT(True, MailDoc).GOTOFIELD("Body")
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