Fine tune Excel to Powerpoint Code

Thanks Andy for this awesome piece of code:

Code:

---

Sub Chart2PPT()
    Dim objPPT As Object
    Dim objPrs As Object
    Dim objSld As Object
    Dim shtTemp As Object
    Dim chtTemp As ChartObject
    Dim objShape As Shape
    Dim objGShape As Shape
    Dim intSlide As Integer
    Dim blnCopy As Boolean
    Set objPPT = CreateObject("Powerpoint.application")
    objPPT.Visible = True
    objPPT.Presentations.Add
    objPPT.ActiveWindow.ViewType = 1 'ppViewSlide
    For Each shtTemp In ThisWorkbook.Sheets
        blnCopy = False
        If shtTemp.Type = xlWorksheet Then
            For Each objShape In shtTemp.Shapes 'chtTemp In shtTemp.ChartObjects
                blnCopy = False
                If objShape.Type = msoGroup Then
                    ' if ANY item in group is a chart
                    For Each objGShape In objShape.GroupItems
                        If objGShape.Type = msoChart Then
                            blnCopy = True
                            Exit For
                        End If
                    Next
                End If
                If objShape.Type = msoChart Then blnCopy = True
                If blnCopy Then
                    intSlide = intSlide + 1
                    objShape.CopyPicture
                    ' new slide for each chart
                    objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.Slides.Add(Index:=objPPT.ActivePresentation.Slides.Count + 1, Layout:=12).SlideIndex
                    objPPT.ActiveWindow.View.Paste
                End If
            Next
            If Not blnCopy Then
                ' copy used range
                intSlide = intSlide + 1
                shtTemp.UsedRange.CopyPicture
                ' new slide for each chart
                objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.Slides.Add(Index:=objPPT.ActivePresentation.Slides.Count + 1, Layout:=12).SlideIndex
                objPPT.ActiveWindow.View.Paste
            End If
        Else
            intSlide = intSlide + 1
            shtTemp.CopyPicture
            ' new slide for each chart
            objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.Slides.Add(Index:=objPPT.ActivePresentation.Slides.Count + 1, Layout:=12).SlideIndex
            objPPT.ActiveWindow.View.Paste
        End If
    Next
    Set objPrs = Nothing
    Set objPPT = Nothing
End Sub

---

What I would like to do, is fine tune it a bit. Right now the code takes charts & tables from all sheets in a workbook. I would like to limit this to only charts on one tab - CHARTS.

I am also looking to tweak this to open an existing presentation, as well as apply a template instead of simply pasting to blank slides.

Any and all help would be greatly appreciated.

Thanks,

Sirius

Hi and welcome to VBAX :hi:

There's quite a lot of code that can be dumped if you just want that specific scenario... The code below just copies the charts from sheet "CHARTS".
I've added a line to open an existing presentation, so you'll have to define a valid path in the constant

Code:

---

Sub Chart2PPT()
    Dim objPPT As Object
    Dim shtTemp As Object
    Dim objShape As Shape
    ' define the path and name of the presentation to open
    Const PRES_FULL_PATH As String = "C:\TEMP\test.ppt"
    Set objPPT = CreateObject("Powerpoint.application")
    objPPT.Visible = True
    objPPT.Presentations.Open PRES_FULL_PATH
    objPPT.ActiveWindow.ViewType = 1    'ppViewSlide
    Set shtTemp = ThisWorkbook.Sheets("CHARTS")
    If shtTemp.Type = xlWorksheet Then
        For Each objShape In shtTemp.Shapes    'chtTemp In shtTemp.ChartObjects
            If objShape.Type = msoChart Then
                ' intSlide = intSlide + 1
                objShape.CopyPicture
                ' new slide for each chart
                objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.Slides.Add(Index:=objPPT.ActivePresentation.Slides.Count + 1, Layout:=12).SlideIndex
                objPPT.ActiveWindow.View.Paste
            End If
        Next
    End If
    Set objPPT = Nothing
End Sub

---

Regarding the other tweak: do you want to apply a design template (to the presentation) or a layout (to the slide)?

Killian:
Thanks for the reply. I tested your code and it works great for ungrouped charts; however I have grouped & ungrouped charts on my worksheet which I would like to export to PP.

For the design template, I am looking to apply the template to the entire presentation.

thanks,

Sirius

OK, we can add the code for dealing with groups from the original code. I made a PasteIntoNewSld routine that is called when each case is found

Code:

---

Sub Chart2PPTv3()
    Dim objPPT As Object
    Dim shtTemp As Object
    Dim objShape As Shape
    Dim objGShape As Shape
    ' define the path and name of the presentation to open
    Const PRES_FULL_PATH As String = "C:\TEMP\test.ppt"
    Set objPPT = CreateObject("Powerpoint.application")
    objPPT.Visible = True
    objPPT.Presentations.Open PRES_FULL_PATH
    objPPT.ActiveWindow.ViewType = 1 'ppViewSlide
    Set shtTemp = ThisWorkbook.Sheets("CHARTS")
    If shtTemp.Type = xlWorksheet Then
        For Each objShape In shtTemp.Shapes 'chtTemp In shtTemp.ChartObjects
            If objShape.Type = msoChart Then
                ' intSlide = intSlide + 1
                objShape.CopyPicture
                ' call routine to create new slide
                PasteIntoNewSld objPPT
            ElseIf objShape.Type = msoGroup Then
                ' if ANY item in group is a chart
                For Each objGShape In objShape.GroupItems
                    If objGShape.Type = msoChart Then
                        objGShape.CopyPicture
                        ' call routine to create new slide
                        PasteIntoNewSld objPPT
                        Exit For
                    End If
                Next
            End If
        Next
    End If
    Set objPPT = Nothing
End Sub


Sub PasteIntoNewSld(objApp As Object)
    Const DESIGN_FULL_PATH As String = "C:\Program Files\Microsoft Office\Templates\Presentation Designs\Beam.pot"
    Dim objSld As Object
    Set objSld = objApp.ActivePresentation.Slides.Add( _
    Index:=objApp.ActivePresentation.Slides.Count + 1, Layout:=12)
    objApp.ActiveWindow.View.GotoSlide Index:=objSld.SlideIndex
    objApp.ActiveWindow.View.Paste
    objSld.ApplyTemplate Filename:=DESIGN_FULL_PATH
End Sub

---