VBA Email Coding to Include Chart in body of email

[jmcdaniel523]

Attempting to have an email send button that then copies the excel sheet range and pastes into the body of the email. I have successfully gotten this part done however, the Chart (Chart 4) wouldn't paste into the body of the email. I then got it to take the chart and make it into a .gif and attach it to the email but I want it to stay in the cell it is and paste into the email directly

Sub email()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Fname As String
    Dim hoja As String
    Dim rng As Range
    Dim celdas As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    
    
    Fname = Environ$("temp") & "\PackRates.gif"
    
    ActiveWorkbook.Worksheets("Glide Rate Tracker").ChartObjects("Chart 4").Chart.Export _
            Filename:=Fname, FilterName:="GIF"
            
    Set rng = Range("A1:L18")

End With
    On Error Resume Next
    With OutMail
        .To = "pdx7-eos-reports@amazon.com;mlukkari@amazon.com;mcjosha@amazon.com"
        .CC = ""
        .BCC = ""
        .Subject = "PDX7 Rate Tracker | Pack |  " & Format(Now, "mm-dd-yy")
        .HTMLBody = " " & RangetoHTML(rng)
        .Attachments.Add ActiveWorkbook.FullName
        .Attachments.Add Fname
        .Display
    End With
    On Error GoTo 0
     
     Kill Fname

    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"
 

    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).PasteSpecial xlPasteAllUsingSourceTheme, , 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

    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=")

    TempWB.Close savechanges:=False
 

    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

 

[jmcdaniel523]

Can anyone show me How do keep that chart intact and pasted into the email body and not just an attachment. I need it to stay in the same spot in the email.

 

[Logit]

Here is a small project used here :

Option Explicit


Sub mailchart()
Dim OutApp As Object
Dim OutMail As Object
Dim vInspector, GetInspector, wEditor As Variant


Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
    .To = "yo momma@nowhere.com"
    .CC = "xyz@anc.com"
    .BCC = "abc@xyz.com"
    .Subject = "Test"
    .Body = "Dear" & "Macro " & vbCrLf
    .Display
    ActiveSheet.Range("B4:R21").Copy
    Set vInspector = OutMail.GetInspector
    Set wEditor = vInspector.WordEditor

    wEditor.Application.Selection.Start = Len(.Body)
    wEditor.Application.Selection.End = wEditor.Application.Selection.Start

    wEditor.Application.Selection.Paste

.Display
End With
End Sub

Download example workbook : WORKS Email Chart In Body.xlsm