Export excel charts to Powerpoint

[ldarley]

Hi all

I'm trying to export all the charts in my workbook to PowerPoint for a report that I've set up. The problem is that unfortunately different people who use it have different versions of excel so I can't reference the Powerpoint object library.

The code I have though is causing PowerPoint to crash, when I paste I want to paste as a picture rather than embedding the chart I've tried various combinations of pastespecial but I can't seem to get it to work. Any help would be much appreciated,

Option Explicit


Dim pptApp As Object
Dim pptPres As Object
Dim pptSlide As Object
Dim pptSlideCount As Integer
Sub ChartsToPowerPoint()
Dim xSheet As Worksheet
Dim xChartsCount As Integer
Dim xChart As Object
Dim xActiveSlideNow As Integer
Dim MySlideArray As Variant
Dim MyRangeArray As Variant
Dim x As Long
Dim shp As Object
Dim sngDefaultSlideWidth As Long

Application.ScreenUpdating = False

On Error Resume Next
For Each xSheet In ActiveWorkbook.Worksheets
xChartsCount = xChartsCount + xSheet.ChartObjects.Count
Next xSheet
If xChartsCount = 0 Then
MsgBox "Sorry, there are no charts to export!"
Exit Sub
End If
Set pptApp = GetObject(, "PowerPoint.Application")
If pptApp Is Nothing Then
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPres = pptApp.Presentations.Add
Set pptSlide = pptPres.Slides.Add(1, 12)
Else
If pptApp.Presentations.Count > 0 Then
Set pptPres = pptApp.ActivePresentation
If pptPres.Slides.Count > 0 Then
xActiveSlideNow = pptApp.ActiveWindow.View.Slide.SlideIndex
Set pptSlide = pptPres.Slides(xActiveSlideNow)
Else
Set pptSlide = pptPres.Slides.Add(1, 12)
End If
Else
Set pptPres = pptApp.Presentations.Add
Set pptSlide = pptPres.Slides.Add(1, 12)
End If
End If
For Each xSheet In ActiveWorkbook.Worksheets
For Each xChart In xSheet.ChartObjects
Call pptFormat(xChart.Chart)
Next xChart
Next xSheet
For Each xChart In ActiveWorkbook.Charts
Call pptFormat(xChart)
Next xChart

sngDefaultSlideWidth = pptPres.PageSetup.SlideWidth
MySlideArray = Array(2, 3, 4, 5, 6, 7, 8, 9)
MyRangeArray = Array(Dashboard.Range("H9:M9"), Dashboard.Range("P9:T9"), _
Dashboard.Range("O20:T20"), Dashboard.Range("H20:M20"), Dashboard.Range("H32:M32"), Dashboard.Range("P32:T32"), Dashboard.Range("H47:M47"), Dashboard.Range("P47:T47"))

For x = LBound(MySlideArray) To UBound(MySlideArray)
MyRangeArray(x).Copy

On Error Resume Next
Set shp = pptPres.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=2)
On Error GoTo 0


With pptPres.PageSetup
shp.Left = (sngDefaultSlideWidth - shp.Width) / 4
shp.Top = (.SlideHeight / 8) - (shp.Height / 2)
shp.Height = 320
shp.Width = 580
End With

Next x


Set pptSlide = Nothing
Set pptPres = Nothing
Set pptApp = Nothing
MsgBox "The slide pack is now ready for editing!"
Application.ScreenUpdating = True


End Sub




Private Sub pptFormat(xChart As Chart)

Dim I As Integer
Dim sngDefaultSlideWidth As Long



On Error Resume Next
xChart.ChartArea.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
pptSlideCount = pptPres.Slides.Count

Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, 12)
pptSlide.Select
pptSlide.Shapes.Paste
sngDefaultSlideWidth = pptPres.PageSetup.SlideWidth

For I = 1 To pptSlide.Shapes.Count
With pptSlide.Shapes(I)
Select Case .Type
Case msoPicture:
.Top = 87.84976
.Left = (sngDefaultSlideWidth - .Width) / 4
.Height = 422.7964
.Width = 646.5262
End Select
End With
Next I


End Sub