Paste Excel range as picture into email body

Question

My aim is to paste a range as an image into an Outlook email. I turned on the references in the VBA editor for MS Excel, Word and Outlook 15.0 as my latest version on my network.

I've spent hours looking through previously answered similar questions.

I cannot save the image as a temporary file/use html to reference the attachment as a solution due to other users not having access to specific drives where it would be temporarily saved if they ran the code on their own machines.

If I remove the email body section the image pastes fine however if I have both pieces of code in together, the email body writes over the image. I do however need the image to be pasted within the email body text.

Sub CreateEmail()

Dim OlApp As Object
Dim OlMail As Object
Dim ToRecipient As Variant
Dim CcRecipient As Variant
Dim PictureRange As Range
Dim OApp As Object, OMail As Object, signature As String

Set OlApp = CreateObject("Outlook.Application")
Set OlMail = OlApp.createitem(olmailitem)

ExtractName = ActiveWorkbook.Sheets("macros").Range("C11").Value

ToRecipient = ActiveWorkbook.Sheets("macros").Range("K11")
OlMail.Recipients.Add ToRecipient

CC_Check = ActiveWorkbook.Sheets("macros").Range("k10")
If CC_Check = "" Then GoTo Skip_CC

CcRecipient = ActiveWorkbook.Sheets("macros").Range("K10")

OlMail.Recipients.Add CcRecipient

OlMail.Subject = ExtractName
signature = OlMailbody
With OlMail
Set PictureRange = ActiveWorkbook.Sheets("DCTVV").Range("A2:D13")
PictureRange.Copy
OlMail.Display

'This section pastes the image             

Dim wordDoc As Word.Document
Set wordDoc = OlMail.GetInspector.WordEditor
wordDoc.Range.PasteAndFormat wdChartPicture

'This section is the email body it needs inserting into

OlMail.body = "Text here," & vbNewLine & vbNewLine & _
        "Today's report is attached." & vbNewLine & _
        "IMAGE NEEDS TO BE PASTED HERE" _
      & vbNewLine & vbNewLine & "More text here" _
      & vbNewLine & vbNewLine & "Kind regards,"
.signature

End With
Set OMail = Nothing
Set OApp = Nothing
OlMail.Attachments.Add ("filepath &attachment1")
OlMail.Attachments.Add ("filepath &attachment2")
'OlMail.Attachments.Add ("filepath &attachment3")

OlMail.Display 

End Sub

Answer 1

If your code suddenly stopped working after migrating to Office 365 or for any other reasons, please refer to the code below. Comments have been added for easy understanding and implementation.

If you have administrative rights then try the registry changes given at below link: https://support.microsoft.com/en-au/help/926512/information-for-administrators-about-e-mail-security-settings-in-outlo

However, as developer, I recommend a code that's rather compatible with all versions of Excel instead of making system changes because system changes will be required on each end user's machine as well.

As the VBA code below use 'Late Binding', it's also compatible with all previous and current versions of MS Office viz. Excel 2003, Excel 2007, Excel 2010, Excel 2013, Excel 2016, Office 365

---

Option Explicit

Sub Create_Email(ByVal strTo As String, ByVal strSubject As String)


    Dim rngToPicture As Range
    Dim outlookApp As Object
    Dim Outmail As Object
    Dim strTempFilePath As String
    Dim strTempFileName As String
    
    'Name it anything, doesn't matter
    strTempFileName = "RangeAsPNG"
    
    'rngToPicture is defined as NAMED RANGE in the workbook, do modify this name before use
    Set rngToPicture = Range("rngToPicture")
    Set outlookApp = CreateObject("Outlook.Application")
    Set Outmail = outlookApp.CreateItem(olMailItem)
  
    'Create an email
    With Outmail
        .To = strTo
        .Subject = strSubject
        
        'Create the range as a PNG file and store it in temp folder
        Call createPNG(rngToPicture, strTempFileName)
        
        'Embed the image in Outlook
        strTempFilePath = Environ$("temp") & "\" & strTempFileName & ".png"
        .Attachments.Add strTempFilePath, olByValue, 0

        'Change the HTML below to add Header (Dear John) or signature (Kind Regards) using newline tag (<br />)
        .HTMLBody = "<img src='cid:" & strTempFileName & ".png' style='border:0'>"

        
        .Display
        
    End With

    Set Outmail = Nothing
    Set outlookApp = Nothing
    Set rngToPicture = Nothing

End Sub

Sub createPNG(ByRef rngToPicture As Range, nameFile As String)

    Dim wksName As String
    
    wksName = rngToPicture.Parent.Name
    
    'Delete the existing PNG file of same name, if exists
    On Error Resume Next
        Kill Environ$("temp") & "\" & nameFile & ".png"
    On Error GoTo 0
    
    'Copy the range as picture
    rngToPicture.CopyPicture
    
    'Paste the picture in Chart area of same dimensions
    With ThisWorkbook.Worksheets(wksName).ChartObjects.Add(rngToPicture.Left, rngToPicture.Top, rngToPicture.Width, rngToPicture.Height)
        .Activate
        .Chart.Paste
        'Export the chart as PNG File to Temp folder
        .Chart.Export Environ$("temp") & "\" & nameFile & ".png", "PNG"
    End With
    Worksheets(wksName).ChartObjects(Worksheets(wksName).ChartObjects.Count).Delete

End Sub

Answer 2

From what I understand the picture pastes fine to email's body, right?

In this case you might just need to add .HTMLBody like so:

olMail.HTMLBody = "Text here," & vbNewLine & vbNewLine & _
        "Today's report is attached." & vbNewLine & _
        .HTMLBody & _
        vbNewLine & vbNewLine & "More text here" & _
        vbNewLine & vbNewLine & "Kind regards,"

Answer 3

This is an example of my code that we use on my job te send emails:

    Call CrearImagen
    ReDim myFileList(0 To Contador - 1)
    For i = 0 To Contador - 1
        myFileList(i) = wb.Path & "\" & Servicio & i & ".jpg"
        ImagenesBody = ImagenesBody & "<img src='cid:" & Servicio & i & ".jpg'>"
    Next i

    With OutMail
        .SentOnBehalfOfName = "ifyouwanttosendonbehalf"
        .Display
        .To = Para
        .CC = CC
        .BCC = ""
        .Subject = Asunto
        For i = 0 To UBound(myFileList)
            .Attachments.Add myFileList(i)
        Next i
        Dim Espacios As String

        Espacios = "<br>"
        For i = 0 To x
            Espacios = Espacios + "<br>"
        Next

        .HTMLBody = Saludo & "<br><br>" & strbody & "<br><br><br>" _
            & ImagenesBody _ 'here are the images
            & Espacios _ 'more text
            & .HTMLBody
        .Display
    End With
    On Error GoTo 0

'Reformateamos el tamaño de las imagénes y su posición relativa al texto

    Dim oL As Outlook.Application

    Set oL = GetObject("", "Outlook.application")
    Const wdInlineShapePicture = 3
    Dim olkMsg As Outlook.MailItem, wrdDoc As Object, wrdShp As Object
    Set olkMsg = oL.Application.ActiveInspector.CurrentItem
    Set wrdDoc = olkMsg.GetInspector.WordEditor
    For Each wrdShp In wrdDoc.InlineShapes
        If wrdShp.Type = wdInlineShapePicture Then
            wrdShp.ScaleHeight = 100
            wrdShp.ScaleWidth = 100
        End If
        If wrdShp.AlternativeText Like "cid:Imagen*.jpg" Then wrdShp.ConvertToShape
    Next

'Limpiamos los objetos
    For i = 0 To UBound(myFileList)
        Kill myFileList(i)
    Next i
    Set olkMsg = Nothing
    Set wrdDoc = Nothing
    Set wrdShp = Nothing
    Set OutMail = Nothing
    Set OutApp = Nothing

Now if you can already create the images, just save them on the workbook path and you can attach them like this. When attaching images I suggest you that the names of the files don't contain spaces, found out this the hard way until figured it out, html won't like them with spaces.