Save Range (as Image) and Attach to Email | Excel VBA Macro
Excel VBA Macro: Save Range (as Image) and Attach to Email
💥Subscribe: / @greggowaffles
Code:
Sub save_range_then_email()
Dim table As Range
Dim myPic As String
Dim myPath As String
Dim ws As Worksheet
Dim cht As ChartObject
Dim lWidth As Long
Dim lHeight As Long
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set ws = ThisWorkbook.Sheets("S&P 500 Stocks")
Set table = ws.Range("A1:C11")
myPath = "C:\Users\greggowaffles\Documents\Youtube Videos\Test\Pictures\"
myPic = "Best Performing Stocks " & Format(Date, "mm-dd-yy") & " " & _
WorksheetFunction.RandBetween(1000, 9999) & ".jpg"
table.CopyPicture xlScreen, xlPicture
lWidth = table.Width
lHeight = table.Height
Set cht = ws.ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight)
cht.Activate
With cht.Chart
.Paste
.Export Filename:=myPath & myPic, filtername:="JPG"
End With
cht.Delete
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "＜BODY style = font-size: 16pt, font-family: Arial＞" & _
"Hi Team, ＜p＞ Please see attachment.＜p＞" & _
"Thank you,＜br＞Greg"
On Error Resume Next
With OutMail
.to = "[email protected]"
.CC = ""
.BCC = ""
.Subject = "S&P 500 Top Performing Stocks 2023"
.Display
.HTMLBody = strbody & .HTMLBody
.Attachments.Add myPath & myPic
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
#excelmacro #excelvba
