Copy range of cells from Excel as picture and add text in the email body

Question

I'm tying to add range of cells as a picture from the active workbook along with some text.

But for some reason it skipping the text and only pasting the image in the email body.

How do I fix this?

Option Explicit
Public Sub POSTRUN()
Dim olApp As Outlook.Application
Set olApp = New Outlook.Application

Dim Olobj As Outlook.Application
Set Olobj = CreateObject("Outlook.Application")


Dim olNs As Outlook.Namespace
Set olNs = olApp.GetNamespace("MAPI")

Dim Inbox  As Outlook.MAPIFolder
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)

Dim subject As String
    subject = ThisWorkbook.Sheets("SendMail").Range("I5").Text
    Debug.Print subject



Dim i As Long
Dim Filter As String
    Filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
                       Chr(34) & " >= '01/01/1900' And " & _
                       Chr(34) & "urn:schemas:httpmail:datereceived" & _
                       Chr(34) & " < '12/31/2100' And " & _
                       Chr(34) & "urn:schemas:httpmail:subject" & _
                       Chr(34) & "Like '%" & subject & "%'"

Dim Items As Outlook.Items
Set Items = Inbox.Items.Restrict(Filter)
    Items.Sort "[ReceivedTime]", False

For i = Items.Count To 1 Step -1
    DoEvents
    If TypeOf Items(i) Is MailItem Then
        Dim Item As Object
        Set Item = Items(i)
        Debug.Print Item.subject ' Print on Immediate Window
        Debug.Print Item.ReceivedTime ' Print on Immediate Window

        Dim r As Range
        Set r = ThisWorkbook.Sheets("post").Range("A1:M30")
        r.Copy

        Dim outMail As Outlook.MailItem
        Set outMail = Olobj.CreateItem(olMailItem)
         Dim body


        Dim ReplyAll As Outlook.MailItem
        Set ReplyAll = Item.ReplyAll
         Dim wordDoc As Word.Document
        Set wordDoc = ReplyAll.GetInspector.WordEditor

        With ReplyAll


             .HTMLBody = "<font size=""3"" face=""Calibri"">" & _
              "Hi  <br><br>" & _
              "The " & Left(ActiveWorkbook.Name, _
                      InStr(ActiveWorkbook.Name, ".") - 1) & _
              "</B> has been posted.<br>" & _
              .HTMLBody

              wordDoc.Range.PasteAndFormat wdChartPicture

             .Display
            Exit For

        End With

      End If
      Next

      End Sub

Possible duplicate of [Write before paste table in Outlook - Excel VBA](https://stackoverflow.com/questions/49514116/write-before-paste-table-in-outlook-excel-vba) — niton, Apr 07 '18 at 12:04

0m3r · Accepted Answer · 2018-04-07T01:28:21.023

Its not skipping, you are simply overriding the HTMLBody with the image your pasting, so what you need to do is work with Paragraphs Object (Word)

Example

With ReplyAll
    .HTMLBody = "<font size=""3"" face=""Calibri"">" & _
                "Hi  <br><br>" & _
                "The " & Left(ActiveWorkbook.Name, _
                         InStr(ActiveWorkbook.Name, ".") - 1) & _
                "</B> has been posted.<br>" & .HTMLBody

    .Display

     With wordDoc.Paragraphs(2)
        .Range.InsertParagraphAfter
        .Range.PasteAndFormat Type:=wdChartPicture
        .Range.ParagraphFormat.LineSpacingRule = wdLineSpaceDouble
     End With
    Exit For
End With

Also remove following code

Dim Olobj As Outlook.Application
Set Olobj = CreateObject("Outlook.Application")
Dim outMail As Outlook.MailItem
Set outMail = Olobj.CreateItem(olMailItem)
Dim body

You already have it

Dim olApp As Outlook.Application
Set olApp = New Outlook.Application
Dim Item As Object
Set Item = Items(i)

Thank you so much sir, because of you i learnt so much.. and thanks to the stackoverflow for creating such a platform like this. — RK144, Apr 08 '18 at 01:11

Copy range of cells from Excel as picture and add text in the email body

1 Answers1

Linked