While piecing together this code, I was able to get it function properly. Thinking I was done, I submitted it to someone who tried to add it as a personal macro and that was when we realized it didn’t work the same. To verify, I added it as a personal macro on my own computer and it still didn’t work.
I have blindly tried a handful of code additions such as ChartObject.Activate
after ThisWorkbook.Activate
but have not had success.
Sub RangeToEmailBody()
Dim TempFilePath As String
Dim xOutApp As Object
Dim xOutMail As Object
Dim xHTMLBody As String
Dim xRg As Range
On Error Resume Next
Set xRg = Application.InputBox(prompt:="Please select the data range:", Type:=8)
If xRg Is Nothing Then Exit Sub
With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With
Set xOutApp = CreateObject("outlook.application")
Set xOutMail = xOutApp.CreateItem(olMailItem)
Call createJpg(ActiveSheet.Name, xRg.Address, "DashboardFile")
TempFilePath = Environ$("temp") & "\"
xHTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "<img src='cid:DashboardFile.jpg'>"
With xOutMail
.Subject = ""
.HTMLBody = xHTMLBody
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
.To = " "
.Cc = " "
.Display
End With
End Sub
Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)
Dim xRgPic As Range
ThisWorkbook.Activate
Worksheets(SheetName).Activate
Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
xRgPic.CopyPicture
With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub
I would expect the selected range to show up in the body of the email but as a personal macro, there is no content inside the “picture”.
This is a guess at the problem. If you’re adding this in a personal macro, ThisWorkbook
refers to the personal workbook. I’m guessing your source range is in a different workbook entirely.
To simplify, I’d do something like this, using a temporary new workbook:
Sub createJpg(rng As Range, nameFile As String)
Dim tempChartObj As ChartObject
Dim tempWb As Workbook
Set tempWb = Workbooks.Add
Set tempChartObj = tempWb.Sheets(1).ChartObjects.Add(rng.Left, rng.Top, rng.Width, rng.Height)
rng.CopyPicture
With tempChartObj
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
tempWb.Close SaveChanges:=False
End Sub
Then call it like this (note that Call
is unnecessary):
createJpg xRg, "DashboardFile"
Tags: email, excelexcel, function, select