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

[kunal86]

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 xublishsource=", _
"align=left xublishsource=")

'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 xublishsource=", _
"align=left xublishsource=")

'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

 

[NeoSez]

I was just watching this video that might help you: