I have a sheet "Graphs" that basically contains all the information I need to send via Outlook email.
I managed to shovel together a macro that will extract the graphs, convert them as images and paste it to Outlook body email, along with some other information from the sheet.
My issue is, that sometimes there is less or more graphs being added to this sheet, and I am not sure how to loop that in the html section of the macro, so it will automatically adjust how many picture to declare and paste to the email body.
Section Private Sub export_chart() set up to extract all graphs as .jpg files.
But on the Private Sub Send_Automate_Mail() I have to declare them one by one:
.Attachments.Add file_path & "Chart_1.jpg"
.Attachments.Add file_path & "Chart_2.jpg"
And add them one by one on the html section:
"<img src='cid:Chart_1.jpg'" & "width='1000' height='460'>" & "<br>" & "<p>" & _
"<img src='cid:Chart_2.jpg'" & "width='450' height='265'>" & _
But because the number of charts are changing, I wonder if there is a way to do this part as a loop as long as there are Chart_1.jpg, Chart_2.jpg... files are present. I am only a beginner of that kind of coding, could someone help me out please?
My current code below. I am happy for any suggestions or a completely new code if there is an easier method out there, I'm kind of lost at this point!
I know there is an easy way to just send the whole sheet as is, but I cannot do that because recipients are having problem viewing (big gaps in-between graphs; email loading slowly). So I have to convert the graphs to pictures.
Thank you in advance!
Option Explicit
Dim folder_path As String
Dim chart_no As Integer
Dim file_path As String
Sub mail_2_IBUhead()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim rng As Range
Dim x As Integer, y As Integer
Dim total_Resource As Integer
Application.ScreenUpdating = False
Sheets("Graphs").Select
Call export_chart
Call Send_Automate_Mail
'Delete the htm file we used in this function
Kill file_path & "Chart_1.jpg"
Kill file_path & "Chart_2.jpg"
Kill file_path & "Chart_3.jpg"
Kill file_path & "Chart_4.jpg"
Kill file_path & "Chart_5.jpg"
Kill file_path & "Chart_6.jpg"
Kill file_path & "Chart_7.jpg"
Kill file_path & "Chart_8.jpg"
Kill file_path & "Chart_9.jpg"
Kill file_path & "Chart_10.jpg"
MsgBox "Draft Mails have been generated", vbDefaultButton1, "Mail Drafted!"
End Sub
Private Sub Send_Automate_Mail()
' This macro would only send the mail
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim strbody_1 As String, strbody_2 As String, strbody_3 As String
' Dim Start_row As Integer, Start_column As Integer, End_row As Integer, End_Column As Integer
' selecting the entire table range in the sheet
Sheets("Graphs").Select
Range("A:P").Select
Set rng = Selection.SpecialCells(xlCellTypeVisible)
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody_1 = "<BODY style=font-size:11pt;font-family:Calibri>Good morning all,<p>" & _
" Please see MTO update for today, <br> </BODY> "
strbody_2 = "<BODY style=font-size:11pt;font-family:Calibri>" & _
" "
strbody_3 = "<BODY style=font-size:11pt;font-family:Calibri> " & _
" </BODY> "
file_path = folder_path & "\"
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "BE. RawData"
.Attachments.Add file_path & "Chart_1.jpg"
.Attachments.Add file_path & "Chart_2.jpg"
.Attachments.Add file_path & "Chart_3.jpg"
.Attachments.Add file_path & "Chart_4.jpg"
.Attachments.Add file_path & "Chart_5.jpg"
.Attachments.Add file_path & "Chart_6.jpg"
.Attachments.Add file_path & "Chart_7.jpg"
.Attachments.Add file_path & "Chart_8.jpg"
.Attachments.Add file_path & "Chart_9.jpg"
.Attachments.Add file_path & "Chart_10.jpg"
.htmlbody = strbody_1 & "<p>" & "<p>" & _
"<img src='cid:Chart_1.jpg'" & "width='1000' height='460'>" & "<br>" & "<p>" & _
"<img src='cid:Chart_2.jpg'" & "width='450' height='265'>" & _
"<img src='cid:Chart_3.jpg'" & "width='450' height='265'>" & _
"<img src='cid:Chart_4.jpg'" & "width='450' height='265'>" & "<br>" & "<p>" & _
"<img src='cid:Chart_5.jpg'" & "width='650' height='300'>" & _
"<img src='cid:Chart_6.jpg'" & "width='650' height='300'>" & "<br>" & "<p>" & _
"<img src='cid:Chart_7.jpg'" & "width='650' height='300'>" & "<br>" & "<p>" & _
"<img src='cid:Chart_8.jpg'" & "width='450' height='265'>" & _
"<img src='cid:Chart_9.jpg'" & "width='450' height='265'>" & "<br>" & "<p>" & _
"<img src='cid:Chart_10.jpg'" & "width='1000' height='460'>" & "<br>" & "<p>" & _
RangetoHTML(rng) & "<br>" & _
strbody_3
.Importance = 2
' display the e-mail message, change it to ".send" to send the mail on running the macro
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' this function is used in code "Send_Automate_Mail"
' do not change the code if you are new to coding :)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
TempWB.Close savechanges:=False
'Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Private Sub export_chart()
' this code will export all the graphs present in the sheet
Dim objCht As ChartObject
Dim myPic As Shape
Dim tempChartObj As ChartObject
Dim x As Integer
folder_path = Application.ActiveWorkbook.Path
' for each graph present in the sheet, it will get exported
Sheets("Graphs").Select
x = 1
For Each objCht In ActiveSheet.ChartObjects
objCht.Chart.Export folder_path & "\Chart_" & x & ".jpg", "JPG"
x = x + 1
Next objCht
End Sub
