Help on PPT Converter

[viveksrkr]

Hi There

I need help from this expert group.

What I need is -

I have a dashboard with 2 dropdowns with multiple values to be selected which generate graphs on their selection. What I need is to move all the graphs available in my dashboard on selecting values from these 2 dropdowns are transferred to a PPT...basically, say I have total of 30 graphs with selection of values from the 2 dropdowns, and I want all these 30 in on PPT (30 slides)

Please help,

Thanks
Vivek

[Admin]

Hi Vivek,

Welcome to ExcelFox !!

try this. Untested. Make necessary changes.

in a standard module


Dim ppApp As Object
Dim ppSlide As Object

Sub kTest()

Dim i As Long, j As Long
Dim cb1 As Object
Dim cb2 As Object
Dim cb1List, cb2List
Dim c As Long

Const ShtName As String = "Sheet1"


'// form control drop down
Set cb1 = Worksheets(ShtName).DropDowns("Drop Down 1") '<<<< adjust the drop down name
Set cb2 = Worksheets(ShtName).DropDowns("Drop Down 2") '<<<< adjust the drop down name

'// if activex dropdown
'Set cb1 = Worksheets("Sheet1").ComboBox1 '<<<< adjust the drop down name
'Set cb2 = Worksheets("Sheet1").ComboBox2 '<<<< adjust the drop down name

cb1List = cb1.List
cb2List = cb2.List

For i = 1 To UBound(cb1List)
cb1.ListIndex = i
For j = 1 To UBound(cb2List)
cb2.ListIndex = j
cb2.OnAction "YourMacroName" '<<<< adjust the drop down change macro name
For c = 1 To cb1.Parent.ChartObjects.Count
CreatePPT
Copy_Paste_to_PowerPoint ppApp, ppSlide, cb1.Parent, cb1.Parent.ChartObjects(c).Chart, xl_Bitmap
Next
Next
Next

End Sub
Sub CreatePPT()

On Error Resume Next
Set ppApp = GetObject(, "Powerpoint.Application")
On Error GoTo 0

If ppApp Is Nothing Then
Set ppApp = CreateObject("Powerpoint.Application")
ppApp.Visible = True
ppApp.presentations.Add
End If

If ppApp.ActivePresentation.Slides.Count = 0 Then
Set ppSlide = ppApp.ActivePresentation.Slides.Add(1, 12) 'ppLayoutBlank
Else
ppApp.ActivePresentation.Slides.Add ppApp.ActivePresentation.Slides.Count + 1, 12
Set ppSlide = ppApp.ActivePresentation.Slides(ppApp.ActivePresen tation.Slides.Count)
End If

End Sub

In a new standard module


Public Enum PasteFormat
xl_Link = 0
xl_HTML = 1
xl_Bitmap = 2
End Enum

Sub Copy_Paste_to_PowerPoint(ByRef ppApp As Object, ByRef ppSlide As Object, ByVal ObjectSheet As Worksheet, _
ByRef PasteObject As Object, Optional ByVal Paste_Type As PasteFormat)

' Modified version of code originally posted here:
' http://www.vbaexpress.com/kb/getarticle.php?kb_id=370

' Modified by : Krishnakumar @ ExcelFox.com
' Used Late binding so that no issues when users have multiple Excel version

Dim PasteRange As Boolean
Dim objChart As ChartObject
Dim lngSU As Long

Select Case TypeName(PasteObject)
Case "Range"
If Not TypeName(Selection) = "Range" Then Application.Goto PasteObject.Cells(1)
PasteRange = True
Case "Chart": Set objChart = PasteObject.Parent
Case "ChartObject": Set objChart = PasteObject
Case Else
MsgBox PasteObject.Name & " is not a valid object to paste. Macro will exit", vbCritical
Exit Sub
End Select

With Application
lngSU = .ScreenUpdating
.ScreenUpdating = 0
End With

ppApp.ActiveWindow.View.GotoSlide ppSlide.slidenumber

If PasteRange Then
If Paste_Type = xl_Bitmap Then
'//Paste Range as Picture
PasteObject.CopyPicture Appearance:=1, Format:=-4147
ppSlide.Shapes.Paste.Select
ElseIf Paste_Type = xl_HTML Then
'//Paste Range as HTML
PasteObject.Copy
ppSlide.Shapes.PasteSpecial(8, link:=1).Select 'ppPasteHTML
ElseIf Paste_Type = xl_Link Then
'//Paste Range as Linked
PasteObject.Copy
ppSlide.Shapes.PasteSpecial(0, link:=1).Select 'ppPasteDefault
End If
Else
If Paste_Type = xl_Link Then
'//Copy & Paste Chart Linked
objChart.Chart.ChartArea.Copy
ppSlide.Shapes.PasteSpecial(link:=True).Select
Else
'//Copy & Paste Chart Not Linked
objChart.Chart.CopyPicture Appearance:=1, Size:=1, Format:=2
ppSlide.Shapes.Paste.Select
End If
End If

'//Center pasted object in the slide
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

With Application
.CutCopyMode = False
.ScreenUpdating = lngSU
End With

AppActivate ("Microsoft Excel")

End Sub

[viveksrkr]

Thanks a lot. I think I am reaching there...few things -

1) Please note I am using MS Excel 2010 which has different properties than 2003 so I hope that is taken care of in you code. If not, please help
2) I am getting an error at cb2.OnAction "YourMacroName" '<<<< adjust the drop down change macro name
The error is OLE Object failed error. I am not sure how to resove this.

[viveksrkr]

Thanks a lot. I think I am reaching there...few things -

1) Please note I am using MS Excel 2010 which has different properties than 2003 so I hope that is taken care of in you code. If not, please help
2) I am getting an error at cb2.OnAction "YourMacroName" '<<<< adjust the drop down change macro name
The error is OLE Object failed error. I am not sure how to resove this.

Team - Let me know your views on this...thanks a lot

[viveksrkr]

Team - Kindly assist on the query I had put up

[technicalupload]

Hi Vivek

I am also using Excel 2010. It is working fine in my machine. Is it possible to share your file with us.

Or Else manually call "cb2.OnAction "YourMacroName""..

Regards