RangeToHTML & Image in Cell - excel

Question

Im trying to generate an email using Ron de Bruin's RangeToHTML and its working perfectly so far however one of my cells ("B26") contains an image and this wont copy into the email.
I've tried and succeded in adding in the image before or after the range but I need this image to appear in this specific cell. Any Ideas how I can get this to work if its at all possible?
Sub SendEmail()
Dim OutlookApp As Outlook.Application
Dim MItem As Outlook.MailItem
Dim cell As Range
Dim Subj As String
Dim EmailAddr As String
Dim Recipient As String
Dim rng As Range
Dim rng2 As Range
Dim StrBody As String
Set rng = Sheets("Email Templates").Range("A1:D29")
'Set rng2 = Sheets("Email Templates").Range("A6:D32").SpecialCells(xlCellTypeVisible)
'Create Outlook object
Set OutlookApp = New Outlook.Application
'Operations Contacts
For Each cell In Sheets("Contacts").Columns("A").Cells.SpecialCells(xlCellTypeVisible)
If cell.Value Like "*#*" Then
EmailAddr = EmailAddr & ";" & cell.Value
End If
Next
'Systems Contacts
For Each cell In Sheets("Contacts").Columns("B").Cells.SpecialCells(xlCellTypeVisible)
If cell.Value Like "*#*" Then
EmailAddr = EmailAddr & ";" & cell.Value
End If
Next
Subj = "Systems Notification | System Outage | " & Sheets("Email Templates").Range("C6") & " " & Sheets("Email Templates").Range("C4") & " " & Sheets("Email Templates").Range("C6")
'Create Mail Item and view before sending
Set MItem = OutlookApp.CreateItem(olMailItem)
With MItem
.To = EmailAddr
.Subject = Subj
.HTMLBody = RangetoHTML(rng)
.Display
End With
End Sub
Function RangetoHTML(rng As Range)
' By Ron de Bruin.
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
Dim r As Long
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past 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).PasteSpecial xlPasteAllUsingSourceTheme, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
For r = 1 To rng.Rows.Count
.Rows(r).RowHeight = rng.Rows(r).RowHeight
Next r
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=")
RangetoHTML = Replace(RangetoHTML, "<!--[if !excel]> <![endif]-->", "")
'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

Answer 1

You can achieve it by taking a screenshot(using VBA Code) of the relevant range (Has to be visible in the screen) and then save and import that image in Outlook..
This will get you started. I have added the comments so you should not have a problem understanding it. If you still do then simply ask.
Option Explicit
Sub SaveRngAsImage()
Dim flName As String
Dim ws As Worksheet
Dim shp As Shape
Dim objChart As ChartObject
Dim chrt As Chart
Set ws = ActiveSheet
'~~> Change as applicable
flName = "C:\Users\routs\Desktop\MyRng.jpg"
'~~> Delete the above image
If Dir(flName) <> "" Then Kill flName
'~~> Check if what the user selected is a valid range
If TypeName(Selection) <> "Range" Then
MsgBox "Select a range first."
Exit Sub
End If
'~~> Take a screenshot of the range
Selection.CopyPicture xlScreen, xlBitmap
DoEvents
'~~> Paste the screenshot in the worksheet and assign it to
'~~> a shape object so that we can use it's approx width and
'~~> Height to create the chart object
With ws
.Paste
DoEvents
Set shp = .Shapes(.Shapes.Count)
Set objChart = ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height)
Set chrt = objChart.Chart
With chrt
shp.Copy '~~> Copy the shape (in case the clipboard is cleared)
.ChartArea.Select
.Paste
'~~> Save the image
.Export ("C:\Users\routs\Desktop\MyRng.jpg")
End With
shp.Delete
objChart.Delete
End With
'~~> Attaching the above image to outlook email body
'https://stackoverflow.com/questions/44869790/embed-picture-in-outlook-mail-body-excel-vba
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "SomeEmail#SomeServer.com"
.Subject = "Attaching an image"
.Attachments.Add flName, 1, 0
.HtmlBody = "<html><p>Dear XYZ</p>" & _
"<img src=""cid:MyRng.jpg"">"
.Display
End With
End Sub
Screenshot