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

问题

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

回答1:

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)

来源：https://stackoverflow.com/questions/49682060/copy-range-of-cells-from-excel-as-picture-and-add-text-in-the-email-body