Not able to display Chart image in range to html code

[ThrottleWorks]

Hi,

I am using below mentioned code to display an e-mail with VBA.
The range contains a chart which is not displayed with this code.

Instead of chart, there is a blank imgae with caption as 'this image can not be currently displayed'.

Can anyone please help me in this.

Please note, I will upload a sample file in some time.

Sub Create_Email()
    EmailSht.Select
    EmailSht.Range("G4:P59").Clear
   
    DodSht.Range("A1:I28").Value = DodSht.Range("A1:I28").Value
   
    DodSht.Range("A1:I55").Copy
    Range("G4").Select
    ActiveSheet.Paste
   
    Dim OutApp As Object
    Dim OutMail As Object
   
    Set Email_Rng = Nothing
    On Error Resume Next
        Set Email_Rng = EmailSht.Range("G1:P58")
        Email_Rng.Font.Size = 10
        Email_Rng.Font.Name = "Calibri"
    On Error GoTo 0

    If Email_Rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
              vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

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

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

    SubjectLine = EmailSht.Range("B1").Value
    FromEmail = EmailSht.Range("B2").Value
    ToEmail = EmailSht.Range("B3").Value
    CcEmail = EmailSht.Range("B4").Value
   
    On Error Resume Next
    With OutMail
        .SentOnBehalfOfName = FromEmail
        .To = ToEmail
        .CC = CcEmail
        .Subject = SubjectLine
        .HTMLBody = RangetoHTML(Email_Rng)
        .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(Email_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"

    Email_Rng.Copy
    Set TempWB = Workbooks.Add(1)
   
    Range("A1").Select
    ActiveSheet.Paste
   
    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

 

[ThrottleWorks]

Hi,

Please find attached file for your reference.

 

[ThrottleWorks]

Using below mentioned link to solve the issue. Seems to be working. Thanks.
http://www.howtobuildsoftware.com/i...-vba-email-with-pasted-chart-and-text-in-body