VBA Add Images into Email Body

[joh2239509]

Hi all, first post!

I have created two ways of embedding chart images via VBA into a new Outlook email:

1) Display the email and then paste the chart image into the body

2) Embed the images via HTML (after attaching files)

Both of these solutions create and send the email which can be viewed in Outlook however here are my problems:

+Paste Feature: Occasionally getting runtime error 4605 "you are not allowed to edit this selection because it is protected"
-- This happens on the "Application.Selection.Paste" line
-- This is random and only happens every once and awhile (annoying)
-- I have tried to un-protect the email item but get another error saying the item is not protected(?)
-- If I click in the email body once it displays the paste function seems to resume just fine
-- Do not believe there is any coding that will "set focus" to the body of the email
-- Other people will be running this file; it needs to be click-button with no issues

+HTML Embed images: This works flawlessly however you cannot view the images via our "Good for Enterprise" app that everyone uses. The whole assignment I was given was to resolve this.
-- In Outlook there are no "attachments" showing, just the images in the email body
-- In the Good app, there are attachments and the images are just an X (not available)
-- Wondering if because my phone and the Good app are not on my network that it's cuasing an issue however with embedding this should not be the case, right?

**Word editor paste code:

Sub sendEmail()
    Dim sendEmail As Integer
    Dim loopCount As Integer
    
    'Verify sending of email
    Sheets("ECC SNAPSHOT").Activate
    sendEmail = MsgBox("Are you ready to send the email?" & vbNewLine & vbNewLine & "Note: this will also save/close the workbook.", vbYesNo + vbQuestion, "Send Email")
    
    If sendEmail = vbYes Then
        'Create email objects
        Set mailApp = CreateObject("Outlook.Application")
        Set mail = mailApp.CreateItem(olMailItem)
        
        'Set email variables
        With mail
            .SentOnBehalfOfName = "(hidden for privacy)"
            .Bcc = "(hidden for privacy)"
            .Subject = "(hidden for privacy)"
            .Body = ""
        End With
        
        'Open email and create Word editor
        mail.Display
        Set wEditor = mailApp.ActiveInspector.wordEditor
        
        'Paste dashboard into email
        Worksheets("ECC SNAPSHOT").Activate
        Range("A5:X16").Copy
        On Error GoTo ErrHandler:
        wEditor.Application.Selection.Paste
        loopCount = 0
        
        'Add space after dashboard
        Worksheets("ECC SNAPSHOT").Activate
        Range("AA1:AA2").Copy
        On Error GoTo ErrHandler:
        wEditor.Application.Selection.Paste
        loopCount = 0
        
        'Add charts to email body
        Worksheets("Graphs").ChartObjects("US Tech").Activate
        ActiveChart.ChartArea.Copy
        On Error GoTo ErrHandler:
        wEditor.Application.Selection.Paste
        loopCount = 0
        
        Worksheets("Graphs").ChartObjects("US APS").Activate
        ActiveChart.ChartArea.Copy
        On Error GoTo ErrHandler:
        wEditor.Application.Selection.Paste
        loopCount = 0
        
        Worksheets("Graphs").ChartObjects("US MS").Activate
        ActiveChart.ChartArea.Copy
        On Error GoTo ErrHandler:
        wEditor.Application.Selection.Paste
        loopCount = 0
        
        'Add space before totals charts
        Worksheets("ECC SNAPSHOT").Activate
        Range("AA1:AB2").Copy
        On Error GoTo ErrHandler:
        wEditor.Application.Selection.Paste
        loopCount = 0
        
        Worksheets("Graphs").ChartObjects("US Total").Activate
        ActiveChart.ChartArea.Copy
        On Error GoTo ErrHandler:
        wEditor.Application.Selection.Paste
        loopCount = 0
        
        Worksheets("Graphs").ChartObjects("CAN Total").Activate
        ActiveChart.ChartArea.Copy
        On Error GoTo ErrHandler:
        wEditor.Application.Selection.Paste
        
        'The following line will send the email
        mail.Send
    Else
        End
    End If
    
    Set mailApp = Nothing
    Set mail = Nothing
    Set olMailItem = Nothing
    Set wEditor = Nothing
    Application.CutCopyMode = False
        
    'Save the workbook, then close it
    Sheets("ECC SNAPSHOT").Activate
    Range("V3").Select
    ThisWorkbook.Close savechanges:=True
    'End procedure if above does not
    End
    
ErrHandler:
    'Limit resume option
    If loopCount < 8000 Then
        loopCount = loopCount + 1
        Resume
    End If
    
    'If limit reached, close email and prompt user
    mail.Close 1
    Sheets("ECC SNAPSHOT").Activate
    Range("V3").Select
    Application.CutCopyMode = False
    MsgBox ("Email creation was unsuccesful after multiple attempts, please try again." + vbNewLine + vbNewLine + _
        "If you notice the email open upon running and the body remains blank, you may try clicking your mouse in the body of the email for it to paste the data.")
    End
End Sub

**HTML embed code:

Sub sendEmail()
    Dim USTechChart As ChartObject
    Dim USAPSChart As ChartObject
    Dim USMSChart As ChartObject
    Dim USTotalChart As ChartObject
    Dim CANTotalChart As ChartObject
    Dim myChart1 As Chart
    Dim myChart2 As Chart
    Dim myChart3 As Chart
    Dim myChart4 As Chart
    Dim myChart5 As Chart
    Dim myPath As String
    Dim myPicture1 As String
    Dim myPicture2 As String
    Dim myPicture3 As String
    Dim myPicture4 As String
    Dim myPicture5 As String
    Dim rng As Range
    
    'Set range and chart objects from worksheet
    Set rng = Sheets("ECC SNAPSHOT").Range("A5:X17")
    Set USTechChart = Sheets("Graphs").ChartObjects("US Tech")
    Set myChart1 = USTechChart.Chart
    Set USAPSChart = Sheets("Graphs").ChartObjects("US APS")
    Set myChart2 = USAPSChart.Chart
    Set USMSChart = Sheets("Graphs").ChartObjects("US MS")
    Set myChart3 = USMSChart.Chart
    Set USTotalChart = Sheets("Graphs").ChartObjects("US Total")
    Set myChart4 = USTotalChart.Chart
    Set CANTotalChart = Sheets("Graphs").ChartObjects("CAN Total")
    Set myChart5 = CANTotalChart.Chart
    
    'Set path and file names for export
    myFileName1 = "myChart1.png"
    myChart1.Export Filename:=ThisWorkbook.Path & "\" & myFileName1, Filtername:="png"
    myFileName2 = "myChart2.png"
    myChart2.Export Filename:=ThisWorkbook.Path & "\" & myFileName2, Filtername:="png"
    myFileName3 = "myChart3.png"
    myChart3.Export Filename:=ThisWorkbook.Path & "\" & myFileName3, Filtername:="png"
    myFileName4 = "myChart4.png"
    myChart4.Export Filename:=ThisWorkbook.Path & "\" & myFileName4, Filtername:="png"
    myFileName5 = "myChart5.png"
    myChart5.Export Filename:=ThisWorkbook.Path & "\" & myFileName5, Filtername:="png"
    
    'Set picture names for use in HTML body
    myPath = ThisWorkbook.Path
    myPicture1 = "myChart1.png"
    myPicture2 = "myChart2.png"
    myPicture3 = "myChart3.png"
    myPicture4 = "myChart4.png"
    myPicture5 = "myChart5.png"

    With CreateObject("Outlook.Application").CreateItem(0)
        .Attachments.Add myPath & "\" & myPicture1
        .Attachments.Add myPath & "\" & myPicture2
        .Attachments.Add myPath & "\" & myPicture3
        .Attachments.Add myPath & "\" & myPicture4
        .Attachments.Add myPath & "\" & myPicture5
        .SentOnBehalfOfName = "(hidden for privacy)"
        .To = ""
        '.Bcc = "(hidden for privacy)"
        .Subject = "(hidden for privacy)"
        .HTMLBody = RangeToHTML(rng) & _
                    (replace the below [ or ] with < or > in the actual code)
                    "[img src=cid:myChart1.png]" & _
                    "[img src=cid:myChart2.png]" & _
                    "[img src=cid:myChart3.png]" & _
                    "[img src=cid:myChart4.png]" & _
                    "[img src=cid:myChart5.png]" & _
        .Display
    End With
    
    'Delete temp image files
    Kill ThisWorkbook.Path & "\" & myPicture1
    Kill ThisWorkbook.Path & "\" & myPicture2
    Kill ThisWorkbook.Path & "\" & myPicture3
    Kill ThisWorkbook.Path & "\" & myPicture4
    Kill ThisWorkbook.Path & "\" & myPicture5
End Sub

Function RangeToHTML(rng As Range)
    'Variables
    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 workbook to receive the data.
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial xlPasteColumnWidths, , False, False
        .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 an .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 the RangetoHTML subroutine.
    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.
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

 

[joh2239509]

For whatever reason I cannot Edit or Delete this post. My code in the second box is a little sloppy and has unneeded code that I was hoping to update. Oh well.

 

[excelwest]

Hi,

for some reason when i apply your code to my file the range I'm copying from one of the tabs pastes correctly into the email body but the chart will not. Any ideas why? I can attach the file if it helps.