VBA Email Coding to Include Chart in body of email

jmcdaniel523

New Member
Joined
Dec 16, 2020
Messages
2
Office Version
  1. 365
Platform
  1. Windows
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

VBA Code:
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
 

Attachments

  • Chart1.PNG
    Chart1.PNG
    151.8 KB · Views: 3
  • Chart2.PNG
    Chart2.PNG
    87.5 KB · Views: 3

Some videos you may like

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.

jmcdaniel523

New Member
Joined
Dec 16, 2020
Messages
2
Office Version
  1. 365
Platform
  1. Windows
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

Well-known Member
Joined
Aug 31, 2016
Messages
3,856
Here is a small project used here :

VBA Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,122,829
Messages
5,598,347
Members
414,232
Latest member
MIA10_KO

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top