Public Sub Create_and_Display_Notes_Email3()
Const EMBED_ATTACHMENT As Long = 1454
Dim NSession As Object 'NotesSession
Dim NUIWorkspace As Object 'NotesUIWorkspace
Dim NDatabase As Object 'NotesDatabase
Dim NUIDocument As Object 'NotesUIDocument
Dim NRichTextAttachment As Object 'NotesRichTextItem
Dim NDocument As Object 'NotesDocument
Dim ToEmail As String, CCEmail As String, BCCEmail As String, Subject As String, Attachments As Variant, BodyText As String
Dim i As Long
Dim DocID As String
With ThisWorkbook.Worksheets(1) 'ActiveSheet
ToEmail = .Range("C3").Value
CCEmail = .Range("C4").Value
BCCEmail = .Range("C5").Value
Subject = .Range("C6").Value
Attachments = .Range("C8:C10").Value
BodyText = Join(Application.Transpose(.Range("C12", .cells(.Rows.Count, "C").End(xlUp)).Value), vbCrLf)
End With
Set NSession = CreateObject("Notes.NotesSession") 'OLE (late binding only) because we access UI classes
Set NUIWorkspace = CreateObject("Notes.NotesUIWorkspace")
Set NDatabase = NSession.GetDatabase("", "")
NDatabase.OpenMail
'Create an email using the Notes UI
Set NUIDocument = NUIWorkspace.ComposeDocument(, , "Memo")
With NUIDocument
.FieldSetText "EnterSendTo", ToEmail
.FieldSetText "EnterCopyTo", CCEmail
.FieldSetText "EnterBlindCopyTo", BCCEmail
.FieldSetText "Subject", Subject
'Insert body text
.GoToField "Body"
.InsertText BodyText & vbLf
'Insert attachments in a rich text item
Set NRichTextAttachment = .Document.CreateRichTextItem("Attachments")
For i = 1 To UBound(Attachments)
If Not IsEmpty(Attachments(i, 1)) Then
If Dir(Attachments(i, 1)) <> vbNullString Then
.InsertText vbLf "File attached: " & Mid(Attachments(i, 1), InStrRev(Attachments(i, 1), "\") + 1)
NRichTextAttachment.EmbedObject EMBED_ATTACHMENT, "", Attachments(i, 1)
End If
End If
Next
'Save this document's ID, so that we can find it in Drafts
DocID = .Document.UniversalID
'Save and close the mail document. This displays the 'Send Mail' dialogue with 5 buttons: Send & Save, Send Only, Save Only, Discard, Cancel
.Save
.Close
'Send 'v' key to click the 'Save Only' button to save mail document in Drafts
Application.Wait DateAdd("s", 3, Now)
AppActivate "Send Mail", True
SendKeys "v"
End With
'Find the document in Drafts
Set NDocument = Find_Document(NDatabase, "($Drafts)", DocID)
'Reopen the document for user review and to update the rich text field containing the attachments
If Not NDocument Is Nothing Then
Set NUIDocument = NUIWorkspace.EditDocument(True, NDocument)
NUIDocument.GoToField "Body"
End If
End Sub
Private Function Find_Document(NMailDb As Object, View As String, DocumentUniversalID As String) As Object
Dim NView As Object, NDoc As Object, NDocNext As Object
Set Find_Document = Nothing
Set NView = NMailDb.GetView(View)
Set NDoc = NView.GetFirstDocument
While Not NDoc Is Nothing And Find_Document Is Nothing
Set NDocNext = NView.GetNextDocument(NDoc)
If NDoc.UniversalID = DocumentUniversalID Then
Set Find_Document = NDoc
End If
Set NDoc = NDocNext
Wend
End Function