VBA to email Excel 2016 Range as JPG in body - not visible

[dougs522]

Hi All,
I am using the attached code to select a range in Excel 2016, convert it to JPG and insert into body of email, sending with Outlook 2016.
I am getting responses from recipients that the image is missing from the body of the email.
I have BCC'd myself on the send, and the image shows on my email when received, but testing it to my private outlook.com email has the same result of no image.

Can anyone advise on the issue and rectification?

Regards, Doug.

[Logit]

.
If you are ok with inserting a copy of the range into the body of the email, instead of pasting an image, this email version works exceptionally well here :

Option Explicit


Sub CopyRows()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
    ws1.Range("A1:M42").Copy '<------------------------------------------------------- change range to be inserted here.
    Mail_Selection_Range_Outlook_Body
End Sub


Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String
Set rng = Nothing
' Only send the visible cells in the selection.
Set rng = Sheets("Sheet1").Range("A1:M42") '<------------------------------------------------------- change range to be inserted here.
If rng Is Nothing Then
    MsgBox "An unknown error has occurred. "
    Exit Sub
End If
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
    .To = "Your email address here in quotes"
    .CC = ""
    .BCC = ""
    .Subject = "Your Subject Here"


    .HTMLBody = "<p>Text above Excel cells" & "<br><br>" & _
                RangetoHTML(rng) & "<br><br>" & _
                "Text below Excel cells.</p>"
    
    ' In place of the following statement, you can use ".Display" to
    ' display the e-mail message.
    '.Send
    .Display
End With
On Error GoTo 0
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    'Close TempWB
    TempWB.Close savechanges:=False
    'Delete the htm file we used in this function
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

[macropod]

Cross-posted at: https://www.mrexcel.com/forum/genera...-jpg-body.html
Please read VBA Express' policy on Cross-Posting in Rule 3: http://www.vbaexpress.com/forum/faq...._new_faq_item3

[dougs522]

[QUOTE=Logit;388816].
If you are ok with inserting a copy of the range into the body of the email, instead of pasting an image, this email version works exceptionally well here :

Hi Logit,
Thanks heaps, that works nicely.
The only bit it misses is there is a chart in the range I was hoping to have included, hence the original method of inserting the the range as an image.
Any thoughts?

...and....Conditional formatting is excluded in the supplied solution...so image solution was required for that also

[gmayor]

What you need is the following, which simply pastes the range into the message body c/w chart

Option Explicit

Sub Mail_Selection_Range_Outlook_Body()
'Graham Mayor - https://www.gmayor.com - Last updated - 08 Mar 2019
'This macro requires the code from
'http://www.rondebruin.nl/win/s1/outlook/openclose.htm
'to open Outlook correctly

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
    
    Set rng = Sheets("Sheet1").Range("A1:F26")    '<-------- change range to be inserted here.
    If rng Is Nothing Then
        MsgBox "An unknown error has occurred. "
        GoTo lbl_Exit
    End If
    rng.Copy 'Copy the range to the clipboard
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Set OutApp = OutlookApp()
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = "someone@somewhere.com"
        .CC = ""
        .BCC = ""
        .Subject = "Your Subject Here"
        .BodyFormat = 2    'html
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor    'access the message body for editing
        Set oRng = wdDoc.Range
        oRng.collapse 1
        oRng.Text = "Please see the following example" & vbCr & vbCr 'Any text before the pasted copy
        oRng.collapse 0
        oRng.Paste
        .Display    'Do not delete this line
        '.send
    End With
    On Error GoTo 0
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
lbl_Exit:
    Set OutMail = Nothing
    Set OutApp = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Set rng = Nothing
    Exit Sub
End Sub