What I need is emailing my colleagues certain cells (from Column A to Column Q) in Excel and the cells are shown as a picture in my email. Below is my code. However, the picture in my draft email is blank. It doesn't show the cells. the interesting thing is the picture (contains the cells I need) is copied in my clipboard and I am able to delete the blank picture and click paste. But I want to make it more automated since this Macro will be eventually available among the entire department. Could anyone help me?
Sub CAS_Reminder()
Dim OutApp As Object
Dim OutMail As Object
Dim Rng As Range
Dim LastRow As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim Recipient_Name As String
Dim StringBody As String
Dim Manager_Name As String
Dim RngHeight As Long
Dim RngWidth As Long
'set last row
LastRow = Range("A1").End(xlDown).Row
' Set the range to be copied
Set Rng = Range("A1", "Q" & LastRow)
' Copy the range and paste as picture
Rng.CopyPicture xlScreen, xlPicture
' Create a temporary file to hold the image
TempFilePath = Environ$("temp") & "\"
TempFileName = "SelectedRanges.png"
' Save the image to the temporary file
With ActiveSheet.ChartObjects.Add(0, 0, Rng.Width, Rng.Height)
.Chart.Paste
.Chart.Export FileName:=TempFilePath & TempFileName, FilterName:="PNG"
.Delete
End With
' Store range dimensions in variables
RngHeight = Rng.Height
RngWidth = Rng.Width
' Create a new email
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
' Set the recipients
Recipient_Name = Range("Q2").Value & "@harriscomputer.com"
Manager_Name = Range("D2").Value & "@harriscomputer.com"
OutMail.To = Recipient_Name
OutMail.CC = Manager_Name
' set subject of the email
OutMail.Subject = "xxx"
'set the body of the email
StringBody = "xxx" & _
"<img src='cid:SelectedRanges.png' height='" & RngHeight & "' width='" & RngWidth & "'>"
OutMail.HTMLBody = StringBody
OutMail.Attachments.Add TempFilePath & TempFileName, 1, 0
OutMail.Display
' Clean up
Kill TempFilePath & TempFileName
Set OutMail = Nothing
Set OutApp = Nothing
Sheets(1).Delete
Application.DisplayAlerts = False
End Sub
Seems like the single .Paste
doesn't always work - sometimes you need to try it multiple times before the chart gets populated with the image. I've seen the same type of thing when trying to paste a copied image to a worksheet (but in that case the failure generates a run-time error). See for example https://stackoverflow.com/a/60582628/478884
This works pretty consistently for me:
Sub CAS_Reminder()
Const RNG_PIC As String = "SelectedRanges.png"
Dim OutApp As Object, OutMail As Object
Dim Rng As Range, LastRow As Long, ws As Worksheet
Dim TempFileName As String, Recipient_Name As String
Dim StringBody As String, Manager_Name As String
Dim RngHeight As Long, RngWidth As Long, attach As Object
Set ws = ActiveSheet
LastRow = ws.Range("A1").End(xlDown).Row
Set Rng = ws.Range("A1:Q" & LastRow)
RngHeight = Rng.Height
RngWidth = Rng.Width
Rng.CopyPicture xlScreen, xlPicture
TempFileName = Environ$("temp") & "\" & RNG_PIC
With ws.ChartObjects.Add(0, 0, RngWidth, RngHeight)
'.Chart.Paste 'pic in mail is blank....
CheckPaste .Chart 'make sure paste succeeded
.Chart.Export Filename:=TempFileName, FilterName:="PNG"
.Delete
End With
Set OutApp = GetObject(, "Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'from Dmitry...
Set attach = OutMail.Attachments.Add(TempFileName)
attach.PropertyAccessor.SetProperty _
"http://schemas.microsoft.com/mapi/proptag/0x3712001F", RNG_PIC
StringBody = "xxx" & _
"<img src='cid:" & RNG_PIC & "' height='" & RngHeight & "' width='" & RngWidth & "'>"
OutMail.HTMLBody = StringBody
OutMail.Display
End Sub
'try >1 paste if needed....
Sub CheckPaste(cht As Chart)
Dim i As Long
Do While cht.DrawingObjects.Count = 0 And i < 5
cht.Paste
DoEvents
i = i + 1
Loop
Debug.Print "Paste count= " & i
End Sub