Inserting picture in Lotus mail thru VBA

[johnjohns]

Hi All,

My very first question in this forum. I was trying to send mails thru Lotus Notes from Excel. It works fine but I cannot insert pictures to the body of mail. Following lines produce no result at all.

MyPic1.Copy
Set Data = New DataObject
Data.GetFromClipboard

I have posted the same question in www.excelforum.com also
http://www.excelforum.com/excel-programming/784527-inserting-picture-in-lotus-mail-thru-vba.html

Can somebody help? VBA codes I used are all picked from this forum and excelforum.com and I don't have much idea on what went wrong and where.

Sub SendMailDirect()
    Dim Session As Object
    Dim Maildb As Object
    Dim MailDoc, UIdoc, WorkSpace As Object
    Dim MyPic As Object
    Dim PeopleToAddress, SendToPeople, CCPeople, BccPeople As String
    Dim MailSubject, Subscription01, Subscription02, Subscription03, Subscription04, BodyOfText As String
    Dim TheAttachment As String
    Dim EmbedObj1 As Object
    Dim attachME As Object
    Dim DraftOrSend As String
    Dim OneCell As Range
    Dim SingleAttachment As Variant
 
    Dim MyPic1, Data As Object
    Set MyPic1 = ActiveSheet.DrawingObjects
 
    For Each OneCell In Selection.Cells
        PeopleToAddress = OneCell.Offset(0, 4).Value
        SendToPeople = OneCell.Offset(0, 1).Value
        CCPeople = OneCell.Offset(0, 2).Value
        BccPeople = OneCell.Offset(0, 3).Value
        BodyOfText = OneCell.Offset(0, 6).Value
        TheAttachment = OneCell.Offset(0, 0).Value
        DraftOrSend = OneCell.Offset(0, 7).Value
        MailSubject = OneCell.Offset(0, 5).Value
        Subscription01 = ActiveSheet.Range("Subscription01").Value
        Subscription02 = ActiveSheet.Range("Subscription02").Value
        Subscription03 = ActiveSheet.Range("Subscription03").Value
        Subscription04 = ActiveSheet.Range("Subscription04").Value
        TheContent = "Dear " & PeopleToAddress & "," & vbNewLine _
          & vbNewLine & vbNewLine _
          & BodyOfText _
          & vbNewLine _
          & vbNewLine & "With Regards," & vbNewLine _
          & vbNewLine & Subscription01 & vbNewLine _
          & Subscription02 & vbNewLine _
          & Subscription03 & vbNewLine _
          & Subscription04 & vbNewLine
        Set Session = CreateObject("Notes.NotesSession")
        Set Maildb = Session.GETDATABASE("", "")
        If Maildb.IsOpen <> True Then
           Maildb.OPENMAIL
        End If
        Set MailDoc = Maildb.CREATEDOCUMENT
        MailDoc.Form = "memo"
 
        MyPic1.Copy
        Set Data = New DataObject
        Data.GetFromClipboard
 
        With MailDoc
          .sendto = SendToPeople
          .Subject = MailSubject
          .Body = TheContent
          .Copyto = CCPeople
          .BlindCopyTo = BccPeople
        End With
        If TheAttachment <> "" Then
           Set attachME = MailDoc.CreateRichTextItem("TheAttachment")
           If InStr(1, TheAttachment, ",") > 0 Then
              For Each SingleAttachment In Split(TheAttachment, ",")
                 Set EmbedObj1 = attachME.EmbedObject(1454, "", Trim(SingleAttachment), "Attachment")
              Next SingleAttachment
           Else
              Set EmbedObj1 = attachME.EmbedObject(1454, "", TheAttachment, "Attachment")
           End If
           MailDoc.CreateRichTextItem ("Attachment")
        End If
        MailDoc.SAVEMESSAGEONSEND = True
        If DraftOrSend <> "Send" Then
           Call MailDoc.Save(True, False)
           MailDoc.RemoveItem ("DeliveredDate")
           Call MailDoc.Save(True, False)
        Else
           MailDoc.PostedDate = Now()
           MailDoc.Send 0, recipient
        End If
        Set objNotesField = Nothing
        Set Session = Nothing
        Set Maildb = Nothing
        Set MailDoc = Nothing
'       Optional code to check if email has been sent
'       MsgBox "Email Successfully sent to " & PeopleToAddress & Email
    Next OneCell
End Sub

 

[Andrew Poulsom]

Welcome to MrExcel.

This may help you:

http://www.mrexcel.com/forum/showthread.php?t=75033

 

[johnjohns]

Thank You Andrew Poulsom. Infact I tried that also. But along with my codes the following one

Call MailDoc.GotoField("Body")

triggers an error. "Object doesnot support this property or method".

 

[Andrew Poulsom]

Sorry, I don't know why you would get that error.

 

[johnjohns]

I wish if I were able to upload my w.book. But this forum does not support it. Anyway thanks for the prompt replies.

 

[johnjohns]

Still, is there a way to solve this issue by amending my above code?

 

[Andrew Poulsom]

Did you try the code in the link I posted and did it work? If so it should be possible to incorporate part of it in yours. Please be aware that I don't have Lotus Notes to test.

 

[johnjohns]

When I fully adopt this module it works

Sub test()
Dim MyPic1 As Object, MyPic2 As Object
Application.ScreenUpdating = False
Set MyPic1 = ActiveSheet.Pictures.Insert( _
****"C:\Temp\Picture 1.jpg")
Set MyPic2 = ActiveSheet.Pictures.Insert( _
****"C:\Temp\Picture 2.jpg")
Call SendMail(MyPic1, MyPic2)
MyPic1.Delete: MyPic2.Delete
Set MyPic1 = Nothing: Set MyPic2 = Nothing
Application.ScreenUpdating = True
End Sub
Private Sub SendMail(ByRef MyPic1 As Object, ByRef MyPic2 As Object)
Dim Notes As Object, db As Object, WorkSpace As Object
Dim UIdoc As Object, UserName As String, MailDbName As String
Set Notes = CreateObject("Notes.NotesSession")
UserName = Notes.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, _
****(Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set db = Notes.GetDataBase(vbNullString, MailDbName)
Set WorkSpace = CreateObject("Notes.NotesUIWorkspace")
Call WorkSpace.ComposeDocument(, , "Memo")
Set UIdoc = WorkSpace.CurrentDocument
Call UIdoc.FieldSetText("SendTo", "John H Deere") 'Recipient
Call UIdoc.FieldSetText("Subject", "Pic Time")
Call UIdoc.GotoField("Body")
Call UIdoc.InsertText(WorksheetFunction.Substitute( _
****"Hey Buddy,@@Check out the pics eh!@@", _
****"@", vbCrLf))
MyPic1.Copy: Call UIdoc.Paste
Call UIdoc.InsertText(String(2, vbCrLf))
MyPic2.Copy: Call UIdoc.Paste
Call UIdoc.InsertText(Application.Substitute( _
****"@@Don't Be A Stranger,@Moi", "@", vbCrLf))
Application.CutCopyMode = False
Call UIdoc.Save(True, True)
Call UIdoc.Send(False)
Call UIdoc.Close
Set UIdoc = Nothing: Set WorkSpace = Nothing
Set db = Nothing: Set Notes = Nothing
End Sub

But where I fail is when incorporating the picture insertion part to my set of codes, which works fine except for this part. Once again thank you for your time and giving me a reply.

 

[johnjohns]

Hope I am not violating the forum rules by asking this again. Can this be helped? I still have no idea why "Object doe snot support this property or method" messages comes when adopting the picture insertion part to my set of codes. I am not that good in VBA, I must confess.

regards

johnjohns

 

[John_w]

Use something like ActiveSheet.Range("A1:E7").CopyPicture to copy a range of cells as an image to the clipboard, then UIDoc.Paste to paste it into the email.