' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub mailLotusNotes()
Dim lngRow As Long
With ActiveSheet 'Sheets("Tabelle1")
For lngRow = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
SendMail_With_LotusNotes .Cells(lngRow, 5).Text, .Cells(lngRow, 4).Text, .Cells(lngRow, 1).Text, _
.Cells(lngRow, 2).Text, .Cells(lngRow, 3).Text, .Cells(lngRow, 6).Text
Sleep 1000
Next
End With
End Sub
Sub SendMail_With_LotusNotes(Body As String, Subject As String, sendTo As String, Optional sendToCC _
As String, Optional sendToBC As String, Optional FileToSend As String)
Dim objSession As Object, objDB As Object, objDocument As Object
Dim objRTItem As Object, objAttachment As Object, objFile As Object
Dim strUser As String, strServer As String, strFile As String
Dim strTO() As String, strCC() As String, strBC() As String
On Error GoTo ErrExit
strTO = Split(sendTo, ";")
If Len(sendToCC) Then strCC = Split(sendToCC, ";")
If Len(sendToBC) Then strBC = Split(sendToBC, ";")
Set objSession = CreateObject("notes.notessession")
strUser = objSession.UserName
strServer = objSession.GetEnvironmentString("MailServer", True)
strFile = objSession.GetEnvironmentString("strFile", True)
Set objDB = objSession.getdatabase(strServer, strFile)
Set objDocument = objDB.createdocument()
objDocument.Form = "Memo"
objDocument.sendTo = strTO
If Len(sendToCC) > 0 Then objDocument.CopyTo = strCC
If Len(sendToBC) > 0 Then objDocument.BlindcopyTo = strBC
objDocument.Subject = Subject
Set objRTItem = objDocument.CREATERICHTEXTITEM("body")
Call objRTItem.APPENDTEXT(Body)
objDocument.SAVEMESSAGEONSEND = True
objDocument.PostedDate = Now
If FileToSend <> "" Then
Set objAttachment = objDocument.CREATERICHTEXTITEM("Attachment")
Set objFile = objAttachment.EMBEDOBJECT(1454, "", FileToSend, "Attachment")
End If
Call objDocument.Send(False)
ErrExit:
With Err
If .Number <> 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
IIf(Erl > 0, "In Zeile " & Erl & vbLf & vbLf, "") & _
.Description & vbLf & vbLf & "In Prozedur (SendMail_With_LotusNotes) in Modul Modul1", _
vbExclamation, "Fehler in Modul1 / SendMail_With_LotusNotes"
End With
Set objRTItem = Nothing
Set objAttachment = Nothing
Set objFile = Nothing
Set objDB = Nothing
Set objDocument = Nothing
Set objSession = Nothing
End Sub