Help on PPT Converter

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

Hi Vivek,

Welcome to ExcelFox !!

try this. Untested. Make necessary changes.

in a standard module

Code:

---

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.ActivePresentation.Slides.Count)
    End If

End Sub

---

In a new standard module

Code:

---

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

---

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.

Quote:

---

Originally Posted by 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

Team - Kindly assist on the query I had put up

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