Link to home
Start Free TrialLog in
Avatar of Andreas Hermle
Andreas HermleFlag for Germany

asked on

copy embedded charts of the active worksheet as picture into PowerPoint aligning them

Dear Experts:

This procedure ....
... copies each embedded chart of the active worksheet as a picture,
... then pastes it onto the second slide in the active PowerPoint presentation.

This code works just fine, but with the disadvantage that ...
... all of the charts get centered on the slide one above the other.

I would like to tweak it so that the following requirements are met:

1. The charts should be scaled down to 80% of their original size
2. There are always only 4 charts to be exported to the second slide. Their names in Excel are:
MyChart_01, MyChart_02, MyChart_03, MyChart_04
The Position of MyChart01 on the second slide (vertically 2 cm from the top margin and horizontally 1 cm from the left margin
The Position of MyChart02 on the second slide: (vertically 10 cm from the top margin and horizontally 1 cm from the left margin)
The Position of MyChart03 on the second slide (vertically 2 cm from the top margin and horizontally 12 cm from the left margin
The Position of MyChart04 on the second slide: (vertically 10 cm from the top margin and horizontally 12 cm from the left margin)
3. Charts that are already on the second slide of the active ppt-presentation have to be deleted first.

Help is very much appreciated. Thank you very much in advance.

Regards, Andreas


Sub ExportCharts_To_PPT_ActivePresentation()
' Set a VBE reference to Microsoft PowerPoint Object Library

'Paste Each Embedded Chart in the Active Worksheet into the second slide in the Active Presentation
'This procedure copies each embedded chart in the active worksheet as a picture from an Excel worksheet,
'then pastes it into the second slide of the active presentation



Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PresentationFileName As Variant
Dim SlideCount As Long
Dim iCht As Integer
Dim ReturnValue As Integer

On Error GoTo ErrorHandling

ReturnValue = MsgBox("Would you like to export all the charts of the active worksheet as PICTURE into the second slide of the ACTIVE PPT ?", vbYesNoCancel, "Exporting charts to Active PPT")


Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewSlide

For iCht = 1 To ActiveSheet.ChartObjects.Count
    ' copy chart as a picture
    ActiveSheet.ChartObjects(iCht).Chart.CopyPicture _
        Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
    
    Set PPSlide = PPPres.Slides(2)
   
    With PPSlide
        ' paste and select the chart picture
        .Shapes.Paste.Select
        ' align the chart
        PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
        PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
        
   
                
    End With

Next

' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing


Exit Sub

ErrorHandling:

If Err.number = 429 Then
MsgBox "The macro cannot find an open ppt presentation in which to export the graphics!" & vbCr & vbCr & _
"Please open either ..." & vbCr & _
"... (1) your ppt-presentation in which you would like the graphics to be inserted" & vbCr & _
"... (2) or just open a blank ppt-file, add a slide and activate the second slide", vbInformation, "No ppt-file found"
ElseIf Err.number = -2147188160 Then
MsgBox "The macro cannot find an open ppt presentation in which to export the graphics!" & vbCr & vbCr & _
"PowerPoint has been started but no file is open!", vbCritical, "No ppt-file found"
Else
MsgBox "The following error has occurred " & Err.number
End If

End Sub

Open in new window

Avatar of Jamie Garroch (MVP)
Jamie Garroch (MVP)
Flag of United Kingdom of Great Britain and Northern Ireland image

Try this Andreas:

Sub ExportCharts_To_PPT_ActivePresentation()
' Set a VBE reference to Microsoft PowerPoint Object Library

'Paste Each Embedded Chart in the Active Worksheet into the second slide in the Active Presentation
'This procedure copies each embedded chart in the active worksheet as a picture from an Excel worksheet,
'then pastes it into the second slide of the active presentation



Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PresentationFileName As Variant
Dim SlideCount As Long
Dim iCht As Integer
Dim ReturnValue As Integer

On Error GoTo ErrorHandling

ReturnValue = MsgBox("Would you like to export all the charts of the active worksheet as PICTURE into the second slide of the ACTIVE PPT ?", vbYesNoCancel, "Exporting charts to Active PPT")


Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewSlide

For iCht = 1 To ActiveSheet.ChartObjects.Count
    ' copy chart as a picture
    ActiveSheet.ChartObjects(iCht).Chart.CopyPicture _
        Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
    
    Set PPSlide = PPPres.Slides(2)
   
    With PPSlide
        ' paste and select the chart picture
      Dim oShp As Shape
      Set oShp = .Shapes.Paste(1)
      With oShp
        ' Scale shape
        .Width = .Width * 0.8: .Height = .Height * 0.8
        Select Case icht
          ' Position = Xcm / 2.54 inches to per cm * 72DPI
          Case 1: .Top = 2 / 2.54 * 72: .Left = 1 / 2.54 * 72
          Case 2: .Top = 10 / 2.54 * 72: .Left = 1 / 2.54 * 72
          Case 3: .Top = 2 / 2.54 * 72: .Left = 12 / 2.54 * 72
          Case 4: .Top = 10 / 2.54 * 72: .Left = 12 / 2.54 * 72
        End Select
      End With
    End With

Next

' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing


Exit Sub

ErrorHandling:

If Err.number = 429 Then
MsgBox "The macro cannot find an open ppt presentation in which to export the graphics!" & vbCr & vbCr & _
"Please open either ..." & vbCr & _
"... (1) your ppt-presentation in which you would like the graphics to be inserted" & vbCr & _
"... (2) or just open a blank ppt-file, add a slide and activate the second slide", vbInformation, "No ppt-file found"
ElseIf Err.number = -2147188160 Then
MsgBox "The macro cannot find an open ppt presentation in which to export the graphics!" & vbCr & vbCr & _
"PowerPoint has been started but no file is open!", vbCritical, "No ppt-file found"
Else
MsgBox "The following error has occurred " & Err.number
End If

End Sub

Open in new window

ASKER CERTIFIED SOLUTION
Avatar of Rgonzo1971
Rgonzo1971

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of Andreas Hermle

ASKER

works like a charm, as always. Thank you very much for your great, professional and swift help.

Regards, Andreas
Hi Jamie,

thank you very much for your swift help. Your code regrettably throws a 13 error code, therefore I awarded the points fully to Rgonzo. His solution works just great.

Nevertheless thank you very much for your great effort and help. I really appreciate it.

Regards, Andreas