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

 

[johnjohns]

Thank you John. Tried that also. All these codes fails when it comes as a part of my set of codes. I have no idea why it happens. At least for the last few months I am making so many blind tries with all the information I could avail from different forums. And yet to succeed! It is a fact that I could not find a logical reason for my failure. I am not that good at VBA especially on excel's integration with other applications.

 

[John_w]

When I fully adopt this module it works


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.

Try this - it works for me. You just need to change the picture file names and email address in the Test subroutine. The Notes GUI must be open and showing the Mail database before you run the code.

Option Explicit

Sub Test()

    Dim picture1 As Object, picture2 As Object
    Dim emailAddress As String
       
    'CHANGE THESE 3 LINES

    emailAddress = "email.address@email.com"
    Set picture1 = ActiveSheet.Pictures.Insert("C:\Path\To\picture1.jpg")
    Set picture2 = ActiveSheet.Pictures.Insert("C:\Path\To\picture2.jpg")
    
    SendMail picture1, picture2, emailAddress
    
    picture1.Delete
    picture2.Delete
    
End Sub

Private Sub SendMail(pic1 As Object, pic2 As Object, SendToEmailAddress 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)
    Set workspace = CreateObject("Notes.NotesUIWorkspace")
    workspace.ComposeDocument , , "Memo"
    
    Set UIDoc = workspace.currentdocument
    With UIDoc
        .FieldSetText "EnterSendTo", SendToEmailAddress
        .FieldSetText "Subject", Now & " 2 pictures in email"
        .GotoField "Body"
        .InsertText "Two pictures are shown below:" & vbLf & vbLf
        pic1.Copy
        .Paste
        .InsertText String(2, vbLf)
        pic2.Copy
        .Paste
        .InsertText String(2, vbLf) & "End of email body text"
        Application.CutCopyMode = False
        .send
        .Close
    End With
    
    Set UIDoc = Nothing
    Set workspace = Nothing
    Set db = Nothing
    Set Notes = Nothing
    
End Sub

 

[johnjohns]

Vow! Great! That solved my issue. Thanks a million John! Just one more question as I am new to this forum. Is there a way to add to your reputation?

With Warm Regards

johnjohns

 

[johnjohns]

Dear John

Allow me to ask one more question, please. How can I include a file (as attachment) in the Lotus mail using your above code?

rgds

johnjohns

 

[johnjohns]

And two more questions. Can we temporarily suppress the 'spell check' option of Lotus thru VBA ? Also is it possible to save the mail as draft than sending it?

 

[johnjohns]

Also it is not working in a loop. The line
workspace.ComposeDocument , , "Memo"
is throwing an error 7412

 

[John_w]

How can I include a file (as attachment) in the Lotus mail using your above code?

One way is by using the MailDoc code from your first post. The following code sends an email with the picture(s) inserted in the body of the email and as attachments.

Sub Test2()

    Dim pictures(1) As Object   'array sized for 2 pictures
    Dim attachments As String
    Dim emailAddress As String
    Dim picture1FileName As String, picture2FileName
    Dim i As Integer
    
    'Edit the next 3 lines as necessary
    emailAddress = "email.address@email.com"
    picture1FileName = "C:\Path\To\picture1.jpg"
    picture2FileName = "C:\Path\To\picture2.jpg"

    'Temporarily put pictures on sheet and create array of pictures to be inserted in email
    
    Set pictures(0) = ActiveSheet.pictures.Insert(picture1FileName)
    Set pictures(1) = ActiveSheet.pictures.Insert(picture2FileName)

    'Comma-separated list of file names to be attached to email
    
    attachments = picture1FileName & "," & picture2FileName
    
    SendMail2 pictures, attachments, emailAddress
    
    For i = LBound(pictures) To UBound(pictures)
        pictures(i).Delete
    Next
    
End Sub


Private Sub SendMail2(pictures() As Object, attachmentFileNames As String, SendToEmailAddress As String)

    Dim Notes As Object, db As Object, workspace As Object, UIDoc As Object
    Dim mailDoc As Object
    Dim attachmentsItem As Object
    Dim embeddedObj As Object
    Dim attachmentFileName As Variant
    Dim i As Integer
    
    Set Notes = CreateObject("Notes.NotesSession")
    Set db = Notes.GETDATABASE("", "")
    If Not db.IsOpen Then db.OPENMAIL
    Set workspace = CreateObject("Notes.NotesUIWorkspace")
    
    Set mailDoc = db.CREATEDOCUMENT
    With mailDoc
        .Form = "memo"
        .sendto = SendToEmailAddress
        .Subject = Now & " test message"
        .Body = "Email body text." & vbLf & "**MARKER TEXT**"
        
        If attachmentFileNames <> "" Then
            Set attachmentsItem = mailDoc.CREATERICHTEXTITEM("Attachments")
            For Each attachmentFileName In Split(attachmentFileNames, ",")
                Set embeddedObj = attachmentsItem.EMBEDOBJECT(1454, "", Trim(attachmentFileName))
            Next
        End If
        
        .Save True, False
    End With
        
    'Edit document to paste pictures in body of email
    
    Set UIDoc = workspace.EDITDocument(True, mailDoc)
    With UIDoc
        .GotoField ("Body")
        .FINDSTRING "**MARKER TEXT**"
        For i = LBound(pictures) To UBound(pictures)
            .InsertText "A picture is shown below:" & vbLf & vbLf
            pictures(i).Copy
            .Paste
            .InsertText vbLf & vbLf
        Next
        .InsertText "End of email body text" & vbLf & vbLf
        Application.CutCopyMode = False
        
        .send
        .Close
    End With
    
    Set UIDoc = Nothing
    Set workspace = Nothing
    Set db = Nothing
    Set Notes = Nothing
    
End Sub

I'm not sure about the spell check or saving in Drafts - try playing around with the .Save and .Send lines or searching.

For the error 7412, post your entire code or enough to reproduce the problem.

 

[johnjohns]

Thank you John. This is the code I used for sending more than one mail and getting the error 7412

Sub Test()
    Dim Picture1 As Object
'   Dim emailAddress, ccAddress, bccAddress As String
    Dim ThePicture As String
    Dim PeopleToAddress, SendToPeople, CCPeople, BccPeople, TheSubscription As String
    Dim TheMailSubject, BodyOfText As String
   'CHANGE THESE 3 LINES
    ThePicture = ActiveSheet.Range("ThePicture").Value
    Set Picture1 = ActiveSheet.Pictures.Insert(ThePicture)
    For Each OneCell In Selection.Cells
        PeopleToAddress = ActiveCell.Offset(0, 3).Value
        SendToPeople = ActiveCell.Offset(0, 0).Value
        CCPeople = ActiveCell.Offset(0, 1).Value
        BccPeople = ActiveCell.Offset(0, 2).Value
        BodyOfText = ActiveCell.Offset(0, 5).Value
        TheMailSubject = ActiveCell.Offset(0, 4).Value
        TheSubscription = ActiveCell.Offset(0, 6).Value
        SendMail Picture1, BodyOfText, PeopleToAddress, TheMailSubject, SendToPeople, CCPeople, BccPeople, TheSubscription
    Next OneCell
    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)
    Set workspace = CreateObject("Notes.NotesUIWorkspace")
    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

Thank you.

regards

johnjohns

 

[johnjohns]

PS
I Have used ony OneCell instead of activecell in the for next loop.

 

[John_w]

Thank you John. This is the code I used for sending more than one mail and getting the error 7412

Your code works for me. Below is my version of your code. I've edited Test to make it easier for me to run, without having to set up cell values, but it is functionally equivalent to your Test subroutine. SendMail() is exactly the same as in your post.

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 10
        PeopleToAddress = "People"
        SendToPeople = "email.address@email.com"   'CHANGE TO A VALID EMAIL ADDRESS
        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)
    Set workspace = CreateObject("Notes.NotesUIWorkspace")
    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