PDA

View Full Version : Solved: Export Shapes to PowerPoint



pedrovarela
09-25-2008, 09:07 AM
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!!!!!!!


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

rbrhodes
09-25-2008, 06:41 PM
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.


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




Old Sub...


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

pedrovarela
09-26-2008, 04:42 AM
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
09-26-2008, 05:14 AM
I find the way through choosing some cells on the intermediary graph and deleting them with .clear. Thanks for the help!!!!!! Very useful!!!!!!