Fine tune Excel to Powerpoint Code

[Sirius Black]

Thanks Andy for this awesome piece of 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.ActivePresentatio n.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.ActivePresentatio n.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.ActivePresentatio n.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

[Killian]

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


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.ActivePresentatio n.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)?

[Sirius Black]

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

[Killian]

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


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