Excel macro to email tables and graphs via Outlook - vba

Question

I am trying to send Automate mail from Excel via Outlook mail to users. Within that i have requirement to send some Excel tables and graphs to certain users. The excel table should be placed after some text provided/written by sender and should retain the same table format in the email.
I am not able to get this functionality automate (sending excel table and graph in the email body) and require your help in sorting this out.
PS: I am using excel/Outlook 2010 (win)
Below is my overall code written as of now:
Sub Mail_to_MgmtTeam()
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
' Delete the Temp sheets, if any (just precautionary step)
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Temp").Delete
Application.DisplayAlerts = True
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Temp"
Sheets("Mail Details").Select
Range("A5").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Temp").Select
Range("A5").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("J:J").EntireColumn.Delete
Columns("A:A").EntireColumn.Delete
Range("A5").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
'' Below code not getting executed successfully
'Selection.Select
'Set rng = Sheets("Temp").Selection.SpecialCells(xlCellTypeVisible)
'rng.Copy
' NEED HELP Here : TO send this selected TABLE within the email BODY to someone...
' code for sending the mails form Excel
Sheets("Mail Details").Select
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Dear " & Cells(x + 5, 3).Value & ", " & _
vbNewLine & vbNewLine & _
"Below Table provides the overall statue of Pending Lists." & _
vbNewLine & vbNewLine & vbNewLine & _
"Thank You " & vbNewLine & "XYZ..."
On Error Resume Next
With OutMail
.To = Sheets("Mail Details").Range("D6").Value
.CC = ""
.BCC = ""
.Subject = "Excel Table Attached"
.Body = strbody
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Mails have been sent", vbDefaultButton1, "Mail Sent!!!"
End Sub
Thanks in advance
Kunal...

Answer 1

I was able to complete the task for which i had posted. I am posting the final code below for anyone who may need help in future on the similar line...
PS:
I have segmented into different sets for easy of use. Please copy each code and paste it in in 'module' back to back
The sheet name should be "RawData" and "ReportData"
The Table should be placed in sheet "RawData" and Column header should be in Row 5
In sheet "RawData", in K Column, Mail ID is mentioned
Macro #1
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("RawData").Select
Call export_chart
Call Send_Automate_Mail
Sheets("RawData").Select
Range("A1").Select
'Delete the htm file we used in this function
Kill file_path & "Chart_1.png"
MsgBox "Draft Mails have been generated", vbDefaultButton1, "Mail Drafted!!!"
End Sub
Macro #2:
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("RawData").Select
Range("A5").Select
Start_row = Selection.Row
Start_column = Selection.Column
Selection.End(xlToRight).Select
End_Column = Selection.Column
Range("A5").End(xlDown).Select
End_row = Selection.Row
Range(Cells(Start_row, 1), Cells(End_row, End_Column)).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>Dear User,<p>" & _
" Below is the Graph.... <br> </BODY> "
strbody_2 = "<BODY style=font-size:11pt;font-family:Calibri>" & _
" Below is the Table... <br> </BODY> "
strbody_3 = "<BODY style=font-size:11pt;font-family:Calibri> This is an Automated mail. Please do not respond. <p> <p> " & _
" Regards, <br> Sender </BODY> "
file_path = folder_path & "\"
With OutMail
.To = Sheets("RawData").Range("k6").Value
.CC = ""
.BCC = ""
.Subject = "BE. RawData"
.Attachments.Add file_path & "Chart_1.png"
.htmlbody = strbody_1 & "<p>" & "<p>" & _
"<img src='cid:Chart_1.png'" & "width='1000' height='580'>" & "<br>" & "<p>" & _
strbody_2 & "<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
Macro #3:
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
Macro #4:
Private Sub export_chart()
' this code will export all the graphs present in the sheet
Dim objCht As ChartObject
Dim x As Integer
folder_path = Application.ActiveWorkbook.Path
' for each graph present in the sheet, it will get exported
Sheets("ReportData").Select
x = 1
For Each objCht In ActiveSheet.ChartObjects
objCht.Chart.Export folder_path & "\Chart_" & x & ".png", "PNG"
x = x + 1
Next objCht
End Sub
Thanks,
Kunal...