Excel macro to email tables and graphs via Outlook

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...