Attempting to email pivot charts for excel

Valshion

New Member
Joined
Sep 11, 2010
Messages
2
I found a wonderful resource @ http://www.rondebruin.nl for macros. I have been doing trail and error. This is a very frustrating experience.
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:eek:ffice:eek:ffice" /><o:p> </o:p>
What I am attempting to email two pivot charts in the same email. I have been able to get one pivot chart to be copied correctly; however I am not able to get the other pivot chart to copy. Instead it copies the rest of the worksheet and emails the document.
<o:p> </o:p>
I would like to have it where one chart is above the other.
<o:p> </o:p>
Thank you for any help you can provide
<o:p> </o:p>
<o:p> </o:p>
Sub EmailMissingImages()<o:p></o:p>
Dim rng As Range<o:p></o:p>
Dim rng1 As Range<o:p></o:p>
Dim rng2 As Range<o:p></o:p>
Dim OutApp As Object<o:p></o:p>
Dim OutMail As Object<o:p></o:p>
<o:p> </o:p>
Set rng = Nothing<o:p></o:p>
On Error Resume Next<o:p></o:p>
<o:p></o:p>
Set rng1 = Selection.SpecialCells(xlCellTypeVisible)<o:p></o:p>
<o:p></o:p>
Set rng1 = Range("AQ3").Select<o:p></o:p>
ActiveSheet.PivotTables("Missing Image Count").PivotSelect "", xlDataAndLabel, True<o:p></o:p>
On Error GoTo 0<o:p></o:p>
<o:p></o:p>
Set rng = Nothing<o:p></o:p>
On Error Resume Next<o:p></o:p>
Set rng2 = Selection.SpecialCells(xlCellTypeVisible)<o:p></o:p>
Set rng2 = Range("N6").Select<o:p></o:p>
ActiveSheet.PivotTables("Missing Image Data").PivotSelect "", xlDataAndLabel, True<o:p></o:p>
On Error GoTo 0<o:p></o:p>
<o:p> </o:p>
If rng2 Is Nothing Then<o:p></o:p>
MsgBox "The selection is not a range or the sheet is protected" & _<o:p></o:p>
vbNewLine & "please correct and try again.", vbOKOnly<o:p></o:p>
Exit Sub<o:p></o:p>
End If<o:p></o:p>
<o:p> </o:p>
With Application<o:p></o:p>
.EnableEvents = False<o:p></o:p>
.ScreenUpdating = False<o:p></o:p>
End With<o:p></o:p>
<o:p> </o:p>
Set OutApp = CreateObject("Outlook.Application")<o:p></o:p>
Set OutMail = OutApp.CreateItem(0)<o:p></o:p>
<o:p> </o:p>
On Error Resume Next<o:p></o:p>
With OutMail<o:p></o:p>
.To ThisWorkbook.Sheets("Email to").Range("b2").Value<o:p></o:p>
.CC = ThisWorkbook.Sheets("Email to").Range("c2").Value<o:p></o:p>
.BCC = ""<o:p></o:p>
.Subject = "This is the Subject line"<o:p></o:p>
.HTMLBody = RangetoHTML(rng2) & RangetoHTML(rng1)<o:p></o:p>
.Send 'or use .Display<o:p></o:p>
End With<o:p></o:p>
On Error GoTo 0<o:p></o:p>
<o:p> </o:p>
With Application<o:p></o:p>
.EnableEvents = True<o:p></o:p>
.ScreenUpdating = True<o:p></o:p>
End With<o:p></o:p>
<o:p> </o:p>
Set OutMail = Nothing<o:p></o:p>
Set OutApp = Nothing<o:p></o:p>
End Sub<o:p></o:p>
Function RangetoHTML(rng As Range)<o:p></o:p>
Dim fso As Object<o:p></o:p>
Dim ts As Object<o:p></o:p>
Dim TempFile As String<o:p></o:p>
Dim TempWB As Workbook<o:p></o:p>
<o:p></o:p>
TempFileName = ThisWorkbook.Sheets("Final Output").Range("N1").Value<o:p></o:p>
<o:p></o:p>
'Copy the range and create a new workbook to past the data in<o:p></o:p>
rng.Copy<o:p></o:p>
Set TempWB = Workbooks.Add(1)<o:p></o:p>
With TempWB.Sheets(1)<o:p></o:p>
.Cells(1).PasteSpecial Paste:=8<o:p></o:p>
.Cells(1).PasteSpecial xlPasteValues, , False, False<o:p></o:p>
.Cells(1).PasteSpecial xlPasteFormats, , False, False<o:p></o:p>
.Cells(1).Select<o:p></o:p>
Application.CutCopyMode = False<o:p></o:p>
On Error Resume Next<o:p></o:p>
.DrawingObjects.Visible = True<o:p></o:p>
.DrawingObjects.Delete<o:p></o:p>
On Error GoTo 0<o:p></o:p>
End With<o:p></o:p>
<o:p></o:p>
With TempWB.PublishObjects.Add( _<o:p></o:p>
SourceType:=xlSourceRange, _<o:p></o:p>
Filename:=TempFile, _<o:p></o:p>
Sheet:=TempWB.Sheets(1).Name, _<o:p></o:p>
Source:=TempWB.Sheets(1).UsedRange.Address, _<o:p></o:p>
HtmlType:=xlHtmlStatic)<o:p></o:p>
.Publish (True)<o:p></o:p>
End With<o:p></o:p>
<o:p></o:p>
Set fso = CreateObject("Scripting.FileSystemObject")<o:p></o:p>
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)<o:p></o:p>
RangetoHTML = ts.ReadAll<o:p></o:p>
ts.Close<o:p></o:p>
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _<o:p></o:p>
"align=left x:publishsource=")<o:p></o:p>
<o:p></o:p>
TempWB.Close savechanges:=False<o:p></o:p>
<o:p></o:p>
Kill TempFile<o:p></o:p>
<o:p></o:p>
Set ts = Nothing<o:p></o:p>
Set fso = Nothing<o:p></o:p>
Set TempWB = Nothing<o:p></o:p>
End Function<o:p></o:p>
<o:p> </o:p>
Private Sub CommandButton1_Click()<o:p></o:p>
Dim PT As PivotTable<o:p></o:p>
Dim WS As Worksheet<o:p></o:p>
<o:p></o:p>
For Each WS In ThisWorkbook.Worksheets<o:p></o:p>
<o:p></o:p>
For Each PT In WS.PivotTables<o:p></o:p>
PT.RefreshTable<o:p></o:p>
Next PT<o:p></o:p>
<o:p></o:p>
Next WS<o:p></o:p>
End Sub
 

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.

Forum statistics

Threads
1,213,562
Messages
6,114,322
Members
448,564
Latest member
ED38

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