VBA to Paste Multiple charts in mail body of outlook from excel

kunal86

New Member
Joined
Apr 20, 2015
Messages
6
Hi,
I have created below code to paste table from excel to mail body of outlook.
Now i wanted to paste two charts (Sheet - Chart1 & Sheet 15-90 ) in mail body of outlook below table pasted in mail body.


Can anyone help me solve this code?


Thanks in Advance.




Sub SendODReportMail()

Dim outlookApp As Object
Dim outlookMailItem As Object
Dim MailBody As String
Dim rng As Range
Dim rng1 As Range


Set currentWB = ActiveWorkbook

currentWB.Activate
Sheets("Sheet1").Select

Set outlookApp = CreateObject("Outlook.Application")
Set outlookMailItem = outlookApp.CreateItem(0)


Set rng = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible)
Set rng1 = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible)


RegardsName = "Dipashree"

MailBody = "Dear Sir," & "<br>" & "<br>" _
& "Please find attached sheet. " & "<br>" _
& RangetoHTML(rng) & "<br>" _
& RangetoHTML1(rng1) & "<br>" _
& "<br>" & "<br>" _
& "Regards" & "<br>" _
& RegardsName & "<br>" _

With outlookMailItem

.To = ""
.CC = ""
.BCC = ""
.HTMLBody = MailBody
.Subject = "Zone 5 OD Ageing Report OD Report " & Date
'.Attachments.Add TempWorkbook.FullName
.Display


End With


Set outlookMailItem = Nothing
Set outlookApp = Nothing


End Sub


Function RangetoHTML(rng As Range)

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"

'currentWB.Activate
Sheets("Sheet1").Select
Range("A7:A7").Select
ActiveSheet.ShowAllData
'Turn off screen updating
Application.ScreenUpdating = False

With ActiveSheet.PivotTables("PivotTable2").PivotFields("Sales Manager")
.PivotItems("Anubhav").Visible = True
.PivotItems("Mithun (Chennai)").Visible = True
.PivotItems("Mithun Muddappa").Visible = True
.PivotItems("Nitin Priyadarshi").Visible = True
.PivotItems("Sandeep Chavan").Visible = True
.PivotItems("sudip das").Visible = True
.PivotItems("Vikas Sawant").Visible = True
.PivotItems("Vikas-HYD").Visible = True
.PivotItems("0").Visible = True
.PivotItems("accounts").Visible = True
.PivotItems("Ajit Acharekar").Visible = True
.PivotItems("Dhiraj Kumar").Visible = True
.PivotItems("Lavin").Visible = True
.PivotItems("Swati").Visible = True
.PivotItems("Vivek Soni").Visible = True
.PivotItems("(blank)").Visible = False
End With

With ActiveSheet.PivotTables("PivotTable2").PivotFields("Employee respons.")
.Orientation = xlRowField
.Position = 3
End With


'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, , True, False
ActiveCell.SpecialCells(xlLastCell).Select
Selection.End(xlToLeft).Select
Selection.End(xlUp).Select
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Columns.AutoFit
Selection.Borders.LineStyle = xlContinuous
.Cells(1).Select
Range("A6").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=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function


Function RangetoHTML1(rng1 As Range)

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"

'currentWB.Activate
Sheets("Sheet1").Select
Range("A7:A7").Select
ActiveSheet.ShowAllData
'Turn off screen updating
Application.ScreenUpdating = False


With ActiveSheet.PivotTables("PivotTable2").PivotFields("Sales Manager")
.PivotItems("Anubhav").Visible = True
.PivotItems("Mithun (Chennai)").Visible = True
.PivotItems("Mithun Muddappa").Visible = True
.PivotItems("Nitin Priyadarshi").Visible = True
.PivotItems("Sandeep Chavan").Visible = True
.PivotItems("sudip das").Visible = True
.PivotItems("Vikas Sawant").Visible = True
.PivotItems("Vikas-HYD").Visible = True
.PivotItems("0").Visible = True
.PivotItems("accounts").Visible = True
.PivotItems("Ajit Acharekar").Visible = True
.PivotItems("Dhiraj Kumar").Visible = True
.PivotItems("Lavin").Visible = True
.PivotItems("Swati").Visible = True
.PivotItems("Vivek Soni").Visible = True
.PivotItems("(blank)").Visible = False
End With

With ActiveSheet.PivotTables("PivotTable2").PivotFields("Employee respons.")
.Orientation = xlHidden
End With


'Copy the range and create a new workbook to past the data in
rng1.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, , True, False
ActiveCell.SpecialCells(xlLastCell).Select
Selection.End(xlToLeft).Select
Selection.End(xlUp).Select
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Columns.AutoFit
Selection.Borders.LineStyle = xlContinuous
.Cells(1).Select
Range("A6").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)
RangetoHTML1 = ts.readall
ts.Close
RangetoHTML1 = Replace(RangetoHTML1, "align=center x:publishsource=", _
"align=left x:publishsource=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
I was just watching this video that might help you:
 
Upvote 0

Forum statistics

Threads
1,223,248
Messages
6,171,027
Members
452,374
Latest member
keccles

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top