VBA - email via Lotus notes

[george hart]

Hi all

The code below works fine in that it sends an email via Lotus Notes to recipients in column H based on a condition.

However, my next task is to somehow email persons attaching two documents. The documents in question will need to be selected

Using something like FileNames = Application.GetOpenFilename(MultiSelect:=True) I quess...Any ideas most appreciated


Dim X As Integer
Dim UserName As String
Dim MailDbName As String
Dim Recipient As Variant
Dim Maildb As Object
Dim MailDoc As Object
Dim AttachME As Object
Dim Session As Object
Dim stSignature As String
Dim myDate As Date
myDate = Date
With Application
.ScreenUpdating = False
.DisplayAlerts = False
For X = 2 To Cells(Rows.Count, "H").End(xlUp).Row
If Range("N" & X) <= 90 _
And Range("J" & X) = "" Or Range("N" & X) <= 60 _
And Range("AB" & X) = "No" And Range("J" & X) < Date Then
' Open and locate current LOTUS NOTES User
Set Session = CreateObject("Notes.NotesSession")
UserName = Session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set Maildb = Session.GETDATABASE("", MailDbName)
If Maildb.IsOpen = True Then
Else
Maildb.OPENMAIL
End If
' Create New Mail and Address Title Handlers
Set MailDoc = Maildb.CREATEDOCUMENT
MailDoc.Form = "Memo"
stSignature = Maildb.GetProfileDocument("CalendarProfile").GetItemValue("Signature")(0)
' Select range of e-mail addresses
Recipient = Array(Range("H" & X) _
.Value)
ccRecipient = Array("Paul.Sidney@firstgroup.com", "Anne.Vinten@firstgroup.com")
MailDoc.SendTo = Recipient
MailDoc.CopyTo = ccRecipient
MailDoc.Subject = "SM procedure " & Range("C" & X).Value & " is due a review"
MailDoc.body = "Please note that safety procedure " & Range("C" & X).Value _
& " is due a review no later than " & Range("L" & X).Value
MailDoc.SAVEMESSAGEONSEND = True
MailDoc.PostedDate = Now()
On Error GoTo errorhandler1
MailDoc.SEND 0, Recipient

MsgBox "Notification sent to " & Range("H" & X).Value & " Advising that " _
& Range("C" & X).Value & " is due a review by " & Range("L" & X).Value
Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing
.ScreenUpdating = True
.DisplayAlerts = True
errorhandler1:
Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing
If Range("H" & X).Value <> "" Then Range("J" & X).Value = Date
End If
Next X
End With
End Sub

Many thanks in advance

 

[george hart]

Re: VBA - email via Lotus notes -Resolved

The code below works a trea, allows one to select attchments and emails accordingly


Option Explicit

Public Sub SendAttachments()
Dim recipients As Variant
Dim emailBodyText As String
Dim FileNames As Variant
FileNames = Application.GetOpenFilename(MultiSelect:=True)
If IsArray(FileNames) Then


recipients = "type email address here"
emailBodyText = "Please find attached implementation plan and procedural document " & vbNewLine & vbNewLine & "Distributed via the Swindon safety department"

Create_and_Send_Notes_Email "implementation plan and procedural document " & Now, recipients, emailBodyText, FileNames
'Next
MsgBox "E-mail sent with attachments"
Else
' Cancel button clicked
MsgBox "E-mail was not sent as no documents were selected."
End If
End Sub
Private Sub Create_and_Send_Notes_Email(Subject As String, recipientsArray As Variant, BodyText As String, Attachments As Variant)
Const EMBED_ATTACHMENT As Long = 1454

'Declare objects for Lotus Notes automation
Dim NSession As Object 'NotesSession
Dim NMailDb As Object 'NotesDatabase
Dim NDoc As Object 'NOTESDOCUMENT - the mail document itself
Dim NRichTextItem As Object 'The attachment rich text file object
Dim NEmbeddedObj As Object 'The embedded object (Attachment)
Dim AttachmentsArray As Variant
Dim I As Integer

'Start a Notes session

Set NSession = CreateObject("Notes.NotesSession") 'Lotus Notes Automation Classes (OLE)
Set NMailDb = NSession.GETDATABASE("", "") 'uses the default .nsf database

If Not NMailDb.IsOpen Then
NMailDb.OPENMAIL
End If
'Create a new mail document

Set NDoc = NMailDb.CREATEDOCUMENT
With NDoc
.Form = "Memo"
.SendTo = recipientsArray
.Subject = Subject
.body = BodyText
.SAVEMESSAGEONSEND = True 'Save sent mail?

If TypeName(Attachments) = "String" Then

'Attachments argument is a comma-separated string of filenames

AttachmentsArray = Split(Attachments, ",")

ElseIf TypeName(Attachments) = "Variant()" Then

'Attachments argument is an array of filename strings
AttachmentsArray = Attachments

End If

'For each attachment, create a rich text item with unique name and an associated embedded object

For I = LBound(AttachmentsArray) To UBound(AttachmentsArray)

Set NRichTextItem = .CREATERICHTEXTITEM("Attachment_" & I)

If Dir(AttachmentsArray(I)) <> "" Then
'Function EMBEDOBJECT(TYPE As Integer, CLASS As String, SOURCE As String, [OBJECTNAME])
Set NEmbeddedObj = NRichTextItem.EMBEDOBJECT(EMBED_ATTACHMENT, "", AttachmentsArray(I))
Else
MsgBox "Attachment file not found: " & AttachmentsArray(I)
End If
Next

'Send the document

'SEND(ATTACHFORM As Integer, [RECIPIENTS])
.send False

'SAVE(FORCE As Integer, MAKERESPONSE As Integer, [MARKREAD]) As Integer
'MARKREAD: True - the document subject is set to black (read) in the Sent folder; False - red (unread)
.Save True, True, False

End With

'Clean up

Set NMailDb = Nothing
Set NDoc = Nothing
Set NRichTextItem = Nothing
Set NSession = Nothing
Set NEmbeddedObj = Nothing

End Sub