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

 

[John_w]

Try UIDoc.SaveMessageOnSend = True, as shown in my code.

 

[klukiyan]

Thank you John for the hint
But it returns me error on this row
According to the "Lotus" reference list, it seems that this command works only in conjunction with [CreateObject("Notes.NotesWorkspace")] but not with [CreateObject("Notes.NotesUIWorkspace")]

Is there any other way to make it save to sent folder?
Thanks a lot

 

[John_w]

According to the "Lotus" reference list, it seems that this command works only in conjunction with [CreateObject("Notes.NotesWorkspace")] but not with [CreateObject("Notes.NotesUIWorkspace")]

Is there any other way to make it save to sent folder?

Are you sure about NotesWorkspace? NotesUIWorkspace is a valid Notes/Domino class, but not NotesWorkspace - see http://publib.boulder.ibm.com/infoc...domino.main.doc/H_NOTESUIWORKSPACE_CLASS.html

I've just run my code in post no. 20 in this thread - http://www.mrexcel.com/forum/showpost.php?p=2813900&postcount=20

and it worked successfully, inserting the image in the body of the email, sending the email and saving it in the Sent folder for 5 messages (all the same). Here is the complete code again:

Option Explicit

Sub Test()
    Dim Picture1 As Object
    Dim ThePicture As String
    Dim PeopleToAddress, SendToPeople, CCPeople, BccPeople, TheSubscription As String
    Dim TheMailSubject, BodyOfText As String
    Dim i As Integer
    
    ThePicture = ActiveSheet.Range("A1").Value
    Set Picture1 = ActiveSheet.pictures.Insert(ThePicture)
    For i = 1 To 5
        PeopleToAddress = "People"
        SendToPeople = "email.address@email.com"
        CCPeople = ""
        BccPeople = ""
        BodyOfText = "Body of text"
        TheMailSubject = Now & " subject"
        TheSubscription = "Subscription"
        SendMail Picture1, BodyOfText, PeopleToAddress, TheMailSubject, SendToPeople, CCPeople, BccPeople, TheSubscription
    Next
    Picture1.Delete
    Set Picture1 = Nothing
End Sub


Private Sub SendMail(pic1 As Object, BodyText, ThePeople, TheSubject, SendToEmailAddress, CCtoEmailAddress, bCCtoEmailAddress, The_Subscription As String)
    Dim Notes As Object, db As Object, workspace As Object, UIDoc As Object
    Dim 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("", MailDbName)
    db.OpenMail
    
    'Debug.Print db.server
    'Debug.Print db.filepath
    'Debug.Print db.Filename
    
    Set workspace = CreateObject("Notes.NotesUIWorkspace")
    'workspace.OpenDatabase db.server, db.filepath
    
    workspace.ComposeDocument , , "Memo"  ' error comes here on second time calling this procedure.
    Set UIDoc = workspace.currentdocument
    With UIDoc
        .FieldSetText "EnterSendTo", SendToEmailAddress
         If Len(CCtoEmailAddress) > 2 Then .FieldSetText "EnterCopyTo", CCtoEmailAddress
         If Len(bCCtoEmailAddress) > 2 Then .FieldSetText "EnterBlindCopyTo", bCCtoEmailAddress
        .FieldSetText "Subject", TheSubject
        .GotoField "Body"
        .InsertText "Dear " & ThePeople & vbLf & vbLf
        .InsertText BodyText
        .InsertText String(2, vbLf)
        .InsertText String(2, vbLf)
         pic1.Copy
        .Paste
        .InsertText String(2, vbLf)
        .InsertText String(2, vbLf)
        .InsertText String(2, vbLf) & " "
         If Len(The_Subscription) > 2 Then .InsertText The_Subscription
        .InsertText String(2, vbLf)
        .InsertText String(2, vbLf)
        .InsertText String(2, vbLf) & " "
         Application.CutCopyMode = False
 
'        .Send
'        .Close
    End With
'   UIDoc.SAVEMESSAGEONSEND = True
    Call UIDoc.Send
    Call UIDoc.Close
    Set UIDoc = Nothing
    Set workspace = Nothing
    Set db = Nothing
    Set Notes = Nothing
 
End Sub

Turns out that UIDoc.SAVEMESSAGEONSEND = True isn't necessary in the code above and it's commented out.

Maybe there is something different about group mailboxes.

 

[klukiyan]

Dear John,
I've tested on user's and team mailbox and you are right, it's different for team mailbox.
Similarly as in the previous example
Uidoc.Document.SaveOptions = "0" is not required in user's mailbox before applying Uidoc.close but is required in team mailbox.
Maybe there are some more options to manipulate the UiDoc.Document.SaveOptions but my VBA competency is still to low for this...

 

[brajesh2020]

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.

I really was able to use the above code.

Only one problem.
below line is giving an error message, it runs properly , but lotus notes shows, no valid recipient error message
Call UIdoc.FieldSetText("SendTo", "brajesh@live.com") 'Recipient