Lotus Notes - Embed image in place of body and attach file

[HaydnMilton]

Hi All,

Please can you help?

Firstly I'm not a programmer... but I can create vba solutions by using the macro recorder & sites like this to find base code that I can modify as needed, most of the time this works.... but this one has me stumped.

My challenge:
Send a LOTUS NOTES email with an embedded image to replace the body text (as formatted text is not a option) AND a attach a file.

So far I have the code below which will send and email with an unformatted text body & an attachment, my boss would really like the email to look more professional.

please can anyone advise how I can replace the body (MailDoc.Body = Btext) with either a copied cell range as a image or import a saved jpg as the embedded body of the email, this way I can get around the body formatting issue in lotus notes.

Any help would be greatly appreciated

Sub Send_Email_With_Attachment()
Dim Username As String
Dim MailDbName As String
Dim Recipient As Variant
Dim ccRecipient As Variant
Dim BccRecipient As Variant
Dim Attachment1 As String
cDim Maildb As Object
Dim MailDoc As Object
Dim Session As Object
Dim stSignature As String
Dim Btext As String

'With Application
'.ScreenUpdating = False
'.DisplayAlerts = False

' 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
MailDoc.SendTo = EmailAddress
MailDoc.CopyTo = CCEmailAddress
MailDoc.BlindCopyTo = BCCEmailAddress

If Site <> "(All)" Then
    MailDoc.Subject = "AAG - Supplier Performance: " & Site
        Else
            If Vendor <> "(All)" Then
                MailDoc.Subject = "AAG - Supplier Performance: " & Vendor
                    Else
                        If Buyer <> "(All)" Then
                            MailDoc.Subject = "AAG - Supplier Performance: " & Buyer
                                Else
                                    MailDoc.Subject = "AAG - Supplier Performance"
                        End If
            End If
End If

' Set Body Text
Btext = "This is an automated email please do not reply to the sender. If you would like to add or remove a person to this e-mail notification make this request via your Ametek point of contact." & vbNewLine & vbNewLine

Btext = Btext & "Dear " & DearTo & "," & vbNewLine & vbNewLine

Btext = Btext & "As part of our program of continuous improvement within Ametek, we would like to share with you this months overview of your delivery & quality performance. Our objective is to find ways to improve performance and effectiveness across the supply chain, by working collaboratively with all our strategic suppliers." & vbNewLine & vbNewLine

MailDoc.Body = Btext

' Select Workbook to Attach to E-Mail
MailDoc.SaveMessageOnSend = True
Attachment1 = sNewFilePath

If Attachment1 <> "" Then
On Error Resume Next
Set AttachME = MailDoc.CREATERICHTEXTITEM("attachment1")
Set EmbedObj1 = AttachME.embedobject(1454, "attachment1", sNewFilePath, "")
On Error Resume Next
End If

MailDoc.PostedDate = Now()
On Error GoTo errorhandler1
MailDoc.SEND 0, Recipient

Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing

errorhandler1:
Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing
End Sub