I am trying to insert a screenshot of an Excel cell range from a specific Sheet into the email body of an outlook message via a macro button. I've tried saving an image as a temporary file but even this doesn't work (and I'd rather avoid that method if possible). Has anyone any suggestions how I can literally grab a cell range in a macro and put that into the email body? Thanks in advance
Sub TakeScreenshotAndEmail()
Dim ws As Worksheet
Dim rng As Range
Dim chartObj As ChartObject
Dim outlookApp As Object
Dim outlookMail As Object
Dim emailDate As String
Dim tempFilePath As String
Dim tempFileName As String
Dim imgTag As String
Dim senderName As String
On Error GoTo ErrorHandler
' Set the worksheet and range
Set ws = ThisWorkbook.Sheets("Summary") ' Change to "Summary" tab
Set rng = ws.Range("A1:N44") ' Change the range as needed
' Define the temporary file path and name
tempFilePath = Environ("TEMP") & "\"
tempFileName = tempFilePath & "temp_image.png"
' Check if the temporary file path exists
If Dir(tempFilePath, vbDirectory) = "" Then
MsgBox "Temporary file path does not exist: " & tempFilePath, vbCritical, "Error"
Exit Sub
End If
' Create a temporary chart to hold the screenshot
Set chartObj = ws.ChartObjects.Add(Left:=rng.Left, Top:=rng.Top, Width:=rng.Width, Height:=rng.Height)
' Copy the range as a picture
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
chartObj.Chart.Paste
chartObj.Chart.Export FileName:=tempFileName, Filtername:="PNG"
chartObj.Delete
' Get the date from cell H3
emailDate = Format(ws.Range("H3").Value, "dd.mm.yyyy")
' Create an Outlook email
Set outlookApp = CreateObject("Outlook.Application")
Set outlookMail = outlookApp.CreateItem(0)
' Get the sender's name
senderName = outlookApp.Session.CurrentUser.Name
' Create the HTML body with the image tag
imgTag = "<img src='cid:image1'>"
With outlookMail
.To = "" ' Change to your recipient
.CC = ""
.BCC = ""
.Subject = "" & emailDate
.HTMLBody = ""
' Embed the image in the email
.Attachments.Add tempFileName, 1, 0, "image1"
.Display ' Use .Send to send the email directly
End With
' Clean up
Kill tempFileName
Set outlookMail = Nothing
Set outlookApp = Nothing
Exit Sub
ErrorHandler:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Error"
End Sub
I tried to write a script several times but naturally failed as this is my first time trying to write a macro