Solved: Export Shapes to PowerPoint

[pedrovarela]

Hi,

I'm almost done with my project but I've found a hard one. I want to export a group of shapes -not chart- (it's a map divided in regions) and some cells (the coloured legend) to a PowerPoint slide. I tried to copy and modified an example that I found on the web but it keeps on giving me errors. Here is the code and attached the file. Probably the code is crappy as I don't have a clue of what I'm changing...

Thanks for your help!!!!!!!

[VBA]
Sub ExportXlGraphSheet2PP()
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim lShapesThisSlide As Long
'Could this be written better?
Sheets("Carte").Select
Worksheets("Carte").Shapes.Select
Set sr = Selection.ShapeRange
ShapeRange.Select
ShapeRange.Copy
On Error Resume Next
Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewSlide
' Reference new instance of PowerPoint
If Err.Number <> 0 Then
Set PPApp = CreateObject("Powerpoint.Application")
Set PPPres = PPApp.Presentations.Add
'Add a slide
PPPres.Slides.Add 1, ppLayoutBlank
PPApp.Visible = True
'Activate PowerPoint
AppActivate PPApp.Name
End If
On Error GoTo 0
' Reference active slide
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutBlank)
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
lShapesThisSlide = PPApp.ActiveWindow.Selection.SlideRange.Shapes.Count
PPApp.ActiveWindow.View.PasteSpecial (ppPasteMetafilePicture)
' .ActiveWindow.View.PasteSpecial (ppPasteOLEObject) 'I changed this to prevent a copy of the complete Excel workbook
'pasted object is 1 count higher than before and no need to select it,justrefer to it
.ActiveWindow.Selection.SlideRange.Shapes(lShapesThisSlide + 1).Name = "Chart"


End Sub
[/VBA]

[rbrhodes]

Hi pv,

Played with it a little and it will now export the 'map'. At this point it also sends your buttons as they are shapes and I haven't got the cell range yet. It's a start tho

<EDIT>

This new one will export as a picture. It works if the sheet is named "Carte" as in the example.

[VBA]
Sub ExportXlGraphSheet2PP_dr()
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim lShapesThisSlide As Long
' Allow errors for If check
On Error Resume Next
Set PPApp = CreateObject("Powerpoint.application")
' Reference active presentation, PP not active will throw error
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewSlide
' On error, reference new instance of PowerPoint
If Err.Number <> 0 Then
Set PPApp = CreateObject("Powerpoint.Application")
Set PPPres = PPApp.Presentations.Add
Set PPPres = PPApp.ActivePresentation
'Add a slide
PPPres.Slides.Add 1, ppLayoutBlank
End If


With Application
' Allow delete
.DisplayAlerts = False
'Speed
.ScreenUpdating = False
End With

Sheets("Carte (2)").Delete

' Create a copy of the sheet
Sheets("Carte").Copy After:=Sheets(1)
' Cut the buttons
With ActiveSheet
.Shapes("Group 810").Cut
.Shapes("Group 807").Cut
End With

' Select the range
Range("A1:O36").Select

' Copy the range as a picture
Selection.CopyPicture Appearance:=xlScreen, _
Format:=xlPicture

' Kill the 'work' sheet
Sheets("Carte (2)").Delete
'Reset excel
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With

'No errors allowed
On Error GoTo 0
' Activate PowerPoint
PPApp.Visible = True
AppActivate PPApp.Name

' Reference active slide
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutBlank)
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex

PPApp.ActiveWindow.ViewType = ppViewSlide
' Get count
lShapesThisSlide = PPApp.ActiveWindow.Selection.SlideRange.Shapes.Count
' Paste to slide
PPApp.ActiveWindow.View.PasteSpecial (ppPasteMetafilePicture)
' Pasted object is 1 count higher than before and no need to select it,just refer to it
PPApp.ActiveWindow.Selection.SlideRange.Shapes(lShapesThisSlide + 1).Name = "Chart"

' Unselect shapes (PP)
PPApp.ActiveWindow.Selection.Unselect

End Sub

[/VBA]


Old Sub...

[vba]
Sub ExportXlGraphSheet2PP()
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim lShapesThisSlide As Long
' Allow errors for If check
On Error Resume Next
Set PPApp = CreateObject("Powerpoint.application")
' Reference active presentation, PP not active will throw error
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewSlide
' On error, reference new instance of PowerPoint
If Err.Number <> 0 Then
Set PPApp = CreateObject("Powerpoint.Application")
Set PPPres = PPApp.Presentations.Add
Set PPPres = PPApp.ActivePresentation
'Add a slide
PPPres.Slides.Add 1, ppLayoutBlank
End If
' Copy all??
Sheets("Carte").Select
Worksheets("Carte").Shapes.SelectAll
Selection.Copy

'Unselect shapes (Excel)
Range("A1").Select
'No errors allowed
On Error GoTo 0
' Activate PowerPoint
PPApp.Visible = True
AppActivate PPApp.Name
' Reference active slide
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutBlank)
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex

PPApp.ActiveWindow.ViewType = ppViewSlide
' Get count
lShapesThisSlide = PPApp.ActiveWindow.Selection.SlideRange.Shapes.Count
' Paste to slide
PPApp.ActiveWindow.View.PasteSpecial (ppPasteShape)
' Pasted object is 1 count higher than before and no need to select it,just refer to it
PPApp.ActiveWindow.Selection.SlideRange.Shapes(lShapesThisSlide + 1).Name = "Chart"

' Unselect shapes (PP)
PPApp.ActiveWindow.Selection.Unselect

End Sub
[/vba]

[pedrovarela]

Thanks!!!!!!! Looks great. Just the legend on the left depends on the type of graph. So depending on the graph I would like to export or not some cells on the left. ANy hint how can I do that? I'll try to delete a group of cells on the intermediary sheet.

[pedrovarela]

I find the way through choosing some cells on the intermediary graph and deleting them with .clear. Thanks for the help!!!!!! Very useful!!!!!!