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.ActivePresentation.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