Send multiple emails to different addresses/pictures from sheet

[pantlegger]

Been trying to put together a macro that has the ability to send three emails to different addresses. The kicker is I want each email to take a picture of a range in the sheet and add it to the body of the email. I have tried a bunch of ways but continue to run into errors. Any help would be great.

 

[pantlegger]

Here is the code I have been able to piece together but, the first email displays wrong file path error. The other two complete just find. I have gone over and over the code but can't figure out where the change is needed. Any Help would be great. Thanks

Sub Email()Sheets("Recap").Select
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim ChartName As String
Dim imgPath As String
Date1 = Date
Date2 = DateAdd("d", -1, Date1)
Dim RecipTO As String
Dim RecipCC As String
Dim RecipTO1 As String
Dim RecipCC1 As String
Dim RecipTO2 As String
Dim RecipCC2 As String
RecipTO = "Email address"
RecipCC = "Email address"
RecipTO1 = "Email address"
RecipCC1 = "Email address"
RecipTO2 = "Email address"
RecipCC2 = "Email address"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set OutMail2 = OutApp.CreateItem(0)
Set OutMail3 = OutApp.CreateItem(0)
Application.ScreenUpdating = False
Application.DisplayAlerts = False


'define a temp path for your image
tmpImageName1 = VBA.Environ$("temp") & "\tempo1.jpg"
tmpImageName2 = VBA.Environ$("temp") & "\tempo2.jpg"
tmpImageName3 = VBA.Environ$("temp") & "\tempo3.jpg"


'Range to save as an image
Set RangeToSend = Worksheets("Recap").Range("B32:AN44")
' Now copy that range as a picture
RangeToSend.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set RangeToSend2 = Worksheets("Recap").Range("B2:AN17")
' Now copy that range as a picture
RangeToSend2.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set RangeToSend3 = Worksheets("Recap").Range("B19:AN30")
' Now copy that range as a picture
RangeToSend3.CopyPicture Appearance:=xlScreen, Format:=xlPicture


' To save this as an Image we need to do a workaround
' First add a temporary sheet and add a Chart there
' Resize the chart same as the size of the range
' Make the Chart border as Zero
' Later once we export that chart as an image
' and save it in the above temporary path
' will delete this temp sheet


Set sht = Sheets.Add
sht.Shapes.AddChart
sht.Shapes.Item(1).Select
Set objChart = ActiveChart


With objChart
.ChartArea.Height = RangeToSend.Height
.ChartArea.Width = RangeToSend.Width
.ChartArea.Fill.Visible = msoFalse
.ChartArea.Border.LineStyle = xlLineStyleNone
.Paste
.Export Filename:=tmpImageName1, FilterName:="JPG"
End With


sht.Shapes.AddChart
sht.Shapes.Item(2).Select
Set objChart2 = ActiveChart


With objChart2
.ChartArea.Height = RangeToSend2.Height
.ChartArea.Width = RangeToSend2.Width
.ChartArea.Fill.Visible = msoFalse
.ChartArea.Border.LineStyle = xlLineStyleNone
.Paste
.Export Filename:=tmpImageName2, FilterName:="JPG"
End With

sht.Shapes.AddChart
sht.Shapes.Item(3).Select
Set objChart3 = ActiveChart


With objChart3
.ChartArea.Height = RangeToSend3.Height
.ChartArea.Width = RangeToSend3.Width
.ChartArea.Fill.Visible = msoFalse
.ChartArea.Border.LineStyle = xlLineStyleNone
.Paste
.Export Filename:=tmpImageName3, FilterName:="JPG"
End With


'Now delete that temporary sheet
sht.Delete


Msg = "****** style='font-size:10pt;font-family:Human BBY Office'>Good morning!"
Msg2 = "****** style='font-size:10pt;font-family:Human BBY Office'>
Good morning!"
Msg3 = "****** style='font-size:10pt;font-family:Human BBY Office'>
Good morning!"



strbody = Msg
strbody2 = Msg2
strbody3 = Msg3







On Error Resume Next



With OutMail
.display
.To = RecipTO
.CC = RecipCC
.Subject = "Email Subject"
.HTMLBody = strbody & "
" & "
" & "

" & "
" & .HTMLBody
'.send
End With

With OutMail2
.display
.To = RecipTO1
.CC = RecipCC1
.Subject = "Email Subject"
.HTMLBody = strbody2 & "
" & "
" & "

" & "
" & .HTMLBody
'.send
End With

With OutMail3
.display
.To = RecipTO
.CC = RecipCC
.Subject = "Email Subject"
.HTMLBody = strbody3 & "
" & "
" & "

" & "
" & .HTMLBody
'.send
End With


On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

 

[pantlegger]

Solved. Had copy and paste altogether. It needed to be moved around.