Insert images from Excel sheet into my mail body

Question

The below is my VBA code without inserting image from Excel sheet.

I was trying to insert some images from my Excel sheet into my mail body. I have code without img.

Sub Mail_Macro_High_Productivity()

Dim EmailApp As Object
Dim EmailItem As Object
Dim tbl_rng As String
Dim rng As Range
Dim ToEmail, CcEmail, Subject, ghNewBody, sht_name, signature As String
Dim i As Integer

    i = 2
    
'//  Looping through the High Productivity Mail Template and getting the values to the variables from the Mail Template Table  //

    Do While Sheets("High Productivity Mail Template").Range("B" & i) <> ""

        Set EmailApp = CreateObject("Outlook.Application")
        Set EmailItem = EmailApp.CreateItem(olMailItem)
        sht_name = Sheets("High Productivity Mail Template").Range("C" & i)
        tbl_rng = Sheets("High Productivity Mail Template").Range("D" & i)
        Set rng = Sheets(sht_name).Range(tbl_rng)
        Sheets("High Productivity Mail Template").Activate
        ToEmail = Sheets("High Productivity Mail Template").Range("F" & i)
        CcEmail = Sheets("High Productivity Mail Template").Range("G" & i)
        Subject = Sheets("High Productivity Mail Template").Range("H" & i)
    
        With EmailItem
            .To = ToEmail
            .CC = CcEmail
            .BCC = " "
            .Subject = Subject

            ghNewBody = "<font style=""font-family: Calibri; font-size: 11pt;""/font>" & _
                        Range("J" & i) & "<br>" & "<br>" & Range("K" & i) & Range("L" & i)

            signature = CreateObject("Scripting.FileSystemObject").GetFile("C:\Users\Joynewton.K\AppData\Roaming\Microsoft\Signatures\Joy Newton Kapildev.htm").OpenAsTextStream(1, -2).ReadAll

            .HTMLBody = ghNewBody & vbCrLf & vbCrLf & RangetoHTML(rng) & _
             "<br>" & "<br>" & signature

            '.display  //  Purposely Commented if uncomment it will displays each mail before sending  //
            .send
        End With

        On Error GoTo 0
        Set EmailApp = Nothing
        Set EmailItem = Nothing
        Set rng = Nothing
        Sheets("High Productivity Mail Template").Range("M" & i).Value = "Mail Sent"
    
    i = i + 1

    Loop

End Sub


Function RangetoHTML(rng As Range)

Dim fso As Object
Dim ts As Object
Dim Tempfile As String
Dim TempWB As Workbook

'//  Copy the range and create a workbook to receive the data.  //

    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).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

---

I am not sure about the image name. The pictures are not downloaded to system even to share the path name. The pictures will be available in one of the Excel sheets.

The user will copy paste the png format images directly from PowerPoint to my Excel automation template sheet.

Answer 1

I Have a old piece of code for Range to Image, the return is a path+filename in your temp. Then you can use the path direct in HTML, will be easy I think?

using:

Sub test()
    Debug.Print fExportRangeToImage(Sheet1.Range("A1:D15"))
End Sub

function:

Public Function fExportRangeToImage(pRange As Range) As String

Dim pic_rng As Range
Dim DisplayAlertsState As Boolean, ScreenUpdatingState As Boolean
Dim defaultPicName As String
Dim fullNameFile As String
Dim ShTemp As Worksheet
Dim ChTemp As Chart
Dim PicTemp As Picture

On Error GoTo errr:

    ScreenUpdatingState = Application.ScreenUpdating
    Application.ScreenUpdating = False
    Set pic_rng = pRange
    defaultPicName = pic_rng.Worksheet.Name & "-" & Replace(Replace(pic_rng.Address, ":", ""), "$", "") & "_" & Format(Now(), "yyyymmdd-hhmmss") & ".jpg"
    Set ShTemp = Worksheets.Add
   
    Charts.Add
    ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name
   
    Set ChTemp = ActiveChart
   
    pic_rng.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
    ChTemp.Paste

    Set PicTemp = Selection
    With ChTemp.Parent
        .Width = PicTemp.Width + 8
        .Height = PicTemp.Height + 8
    End With
   
    fullNameFile = Environ("TEMP") & "\" & defaultPicName
    ChTemp.Export Filename:=fullNameFile, FilterName:="jpg"
   
    DisplayAlertsState = Application.DisplayAlerts
    Application.DisplayAlerts = False
    ShTemp.Delete
    Application.DisplayAlerts = DisplayAlertsState
    Application.ScreenUpdating = ScreenUpdatingState
   
    fExportRangeToImage = fullNameFile
   
errr:

    If Err.Number <> 0 Then
       
        Debug.Print Err.Number & " - " & Err.Description
        fExportRangeToImage = ""
        Err.Clear
       
    End If
   
End Function