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