Paste Chart into Email Body

sreynolds

New Member
Joined
Feb 12, 2016
Messages
9
I am using excel and Outlook 2010, and I am trying to get the below code to paste a chart from excel to the body of an outlook email. The code does not show the chart. I was wondering what I need to change to have the chart show up??

Code:
Sub Email_Turnover()    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Sht As String
    Sht = ActiveWorkbook.ActiveSheet.Range("F3").Value
    Dim ws As Worksheet
    Set ws = Sheets(Sht)
    Dim sbj As String
    Dim Line As String
    Line = ActiveWorkbook.ActiveSheet.Range("B3").Value
    Dim dte As Date
    dte = Date
    Dim CheckBox1 As Object
    Set CheckBox1 = Sheets(Sht).CheckBox1
    
    If CheckBox1 = False Then
        MsgBox "You must verify that you are ready to email this communication. Please check the box."
        Exit Sub
    End If
    
    If Line = "FT 55" Then
        sbj = "FT 55 Daily Communication"
    ElseIf Line = "ML11" Then
        sbj = "ML11 communication"
    ElseIf Line = "Fully Lathed" Then
        sbj = "Fully Lathed Communication"
    End If
    
    Set rng = Nothing
    On Error Resume Next
    
    ws.Unprotect
    Set rng = ws.Range("A1:P55")
    
    On Error GoTo 0


    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With


    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)


    On Error Resume Next
    With OutMail
        .To = "FT 55 Daily Communication"
        .CC = ""
        .BCC = ""
        .Subject = sbj & " " & dte & " " & Sht & " " & "Shift"
        .HTMLBody = RangetoHTML(rng)
        .Display
    End With
    On Error GoTo 0


    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With


    Set OutMail = Nothing
    Set OutApp = Nothing
    
    Sheets(Sht).CheckBox1 = False
    ws.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingHyperlinks:=True
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 paste 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

 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.

baitmaster

Well-known Member
Joined
Mar 12, 2009
Messages
2,039
I've stepped through your code and I think there's more than one place that you're losing your chart

Firstly,
Code:
.Cells(1).PasteSpecial Paste:=8
isn't pasting a chart to your temp file. Replacing this with
Code:
ActiveSheet.Paste
helps but doesn't solve the problem. You do now have a chart in your temp file but it still isn't making it to the email

Instead of creating a temp file, I've saved it as a .htm on my machine so I can see what's there once published. Hey presto, no chart

So you also need to look at the TempWB.PublishObjects feature. I've tried replacing xlSourceRange and TempWB.Sheets(1).UsedRange.Address with xlSourceChart and TempWB.Sheets(1).ChartObjects("Chart 1") respectively, but now I get a message saying that feature is no longer available in this version of Excel. I've just been moved to Excel 2013
 

baitmaster

Well-known Member
Joined
Mar 12, 2009
Messages
2,039

ADVERTISEMENT

Always trust Ron de Bruin. He's noted in his code that it works in 2016 so I'd be more than happy using that approach
 

sreynolds

New Member
Joined
Feb 12, 2016
Messages
9
baitmaster I was talking about

"you also need to look at the TempWB.PublishObjects feature. I've tried replacing xlSourceRange and TempWB.Sheets(1).UsedRange.Address with xlSourceChart and TempWB.Sheets(1).ChartObjects("Chart 1") respectively, but now I get a message saying that feature is no longer available in this version of Excel. I've just been moved to Excel 2013"

Ron de Bruin code works except some of the format changes. I have merged cells with text in it. If the box is filled with text it expands the box across instead leaving in the format it was in.



 

sreynolds

New Member
Joined
Feb 12, 2016
Messages
9

ADVERTISEMENT

John W thanks for the link. Ron de Bruin code works except some of the format changes. I have merged cells with text in it. If the box is filled with text it expands the box across instead leaving in the format it was in.
 

baitmaster

Well-known Member
Joined
Mar 12, 2009
Messages
2,039
Oh right yeah I get you now!

I can't say, my guess is the approach has become obsolete but as I only have 2013 on this machine now I'm unable to test it on earlier versions to see if there's anything else causing problems
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,752
Try this. It saves the chart cells as a temporary .png image and puts the image in the email body using the HTML:

< img src='cid:image.png'>

and sets the PR_ATTACH_CONTENT_ID property.

The code uses early binding of the Outlook classes so you need to set a reference to the Outlook Object Library (Tools -> References in the VBA editor).
Code:
Public Sub Send_Outlook_Email()

    Dim MailTo As String, MailCC As String, MailSubject As String
    Dim ExcelCells As Range
    Dim tempFile As String, imageFileName As String
    Dim HTML As String
    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    Dim OutAttachments As Outlook.Attachments
    Dim OutAttachment As Outlook.Attachment
    Dim OutPropertyAccessor As Outlook.PropertyAccessor
    
    Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
    
    'Cells to be embedded as an image in the email body
    
    Set ExcelCells = Sheets("Sheet1").Range("A1:P55")
    
    'Change email addresses and subject as required
    
    MailTo = "email1@address.com"
    MailCC = "email2@address.com;email3@address.com"
    MailSubject = "Email with embedded image"
    
    'Save the cells as a temporary .png file
    
    imageFileName = "image" & Format(Now, "hhnnss") & ".png"
    tempFile = Environ$("temp") & "\" & imageFileName
    Save_Object_As_PNG ExcelCells, tempFile
    
    'Email body text using HTML, change as required
    '(Forum workaround: need a space in each tag to prevent forum rendering the HTML)

    HTML = "< p>The Excel cells are embedded as an image in the email body:< /p>" & _
           "< img src='cid:" & imageFileName & "'>" & _
           "< p>End of email body.< /p>"
    HTML = Replace(HTML, "< ", "<")

    Set OutApp = New Outlook.Application
    Set OutMail = OutApp.CreateItem(olMailItem)
        
    'Create and send the email

    With OutMail
        
        'Add the image as an attachment and set the Content-Id property to the file name of the image
        
        Set OutAttachments = .Attachments
        Set OutAttachment = OutAttachments.Add(tempFile)
        Set OutPropertyAccessor = OutAttachment.PropertyAccessor
        OutPropertyAccessor.SetProperty PR_ATTACH_CONTENT_ID, imageFileName
        
        .HTMLBody = HTML
        .To = MailTo
        .CC = MailCC
        .Subject = MailSubject
        
        .Display
        .Send
    End With
       
    'Delete the image file
    
    Kill tempFile
    
    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub


'Based on http://www.jpsoftwaretech.com/export-excel-range-to-a-picture-file/

Private Sub Save_Object_As_PNG(saveObject As Object, PNGfileName As String)

    'Save a picture of an object as a .PNG file
    
    'Arguments
    'saveObject     - any object in the CopyPicture method's 'Applies To' list, for example a Range or Shape
    'PNGfileName    - the file name (including folder path) the picture will be saved as
        
    Dim temporaryChartObject As ChartObject
     
    Application.ScreenUpdating = False
    saveObject.CopyPicture xlScreen, xlPicture
    Set temporaryChartObject = ActiveSheet.ChartObjects.Add(0, 0, saveObject.Width, saveObject.Height)
    With temporaryChartObject
        .Border.LineStyle = xlLineStyleNone      'No border
        .Chart.Paste
        .Chart.Export PNGfileName
        .Delete
    End With
    Application.ScreenUpdating = True
    
    Set temporaryChartObject = Nothing
    
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,129,752
Messages
5,638,162
Members
417,011
Latest member
Amaden95

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