Copying Charts from Excel to PowerPoint with Special Paste doesn't work anymore

Question

i´m using VBA in Excel to go through all Chart-Sheets and copy them to a existing PowerPoint-presentation. Until today the program worked fine. But since today it doesn´t copy the Charts to PowerPoint anymore. The program works like: go through all Chart-Sheets and call a Helpfunction. The helpfunction copys the ChartArea and pastes it with:

With pptApp.ActiveWindow
    .ViewType = ppViewNormal
    .View.PasteSpecial DataType:=ppPasteOLEObject, link:=msoTrue
End With

on the PowerPoint. But the Problem here is that the PasteSpecial doesn´t work anymore and i don´t understand why. Thank you for your help. Here is the full code:

'Declaring the necessary Power Point variables (are used in both subs).
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptSlideCount As Integer

Sub ChartsToPowerPoint()

Dim ws As Worksheet
Dim intChNum As Integer: intChNum = 0
Dim objCh As Object
Dim ppPres As String
Dim counter As Integer
Dim rng As Range
Dim oChart As Chart
Dim zähler As Integer

Set rng = ActiveWorkbook.Sheets("Daten").Range("A1:Z200").Find("Pfad für die Powerpoint")
ppPres = rng.Offset(1, 0).Value

counter = 4

For Each ws In ActiveWorkbook.Worksheets
   intChNum = intChNum + ws.ChartObjects.Count
Next ws

zähler = ActiveWorkbook.Charts.Count

'Count the embedded charts.
'For Each ws In ActiveWorkbook.Worksheets
 '   intChNum = intChNum + ws.ChartObjects.Count
'Next ws

'Check if there are chart (embedded or not) in the active workbook.
If intChNum + ActiveWorkbook.Charts.Count < 1 Then
    MsgBox "Sorry, there are no charts to export!", vbCritical, "Ops"
    Exit Sub
End If

'Open PowerPoint and create a new presentation.
Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Open(ppPres)

'Loop through all the embedded charts in all worksheets.
For Each ws In ActiveWorkbook.Worksheets
    For Each objCh In ws.ChartObjects
        Call pptFormat(objCh.Chart, counter)
    Next objCh
Next ws

'Loop through all the chart sheets.
For Each objCh In ActiveWorkbook.Charts
    Call pptFormat(objCh, counter)
    counter = counter + 1
Next objCh

'Show the power point.
pptApp.Visible = True

'Cleanup the objects.
Set pptSlide = Nothing
Set pptPres = Nothing
Set pptApp = Nothing

'Infrom the user that the macro finished.
'MsgBox "The charts were copied successfully to the new presentation!", vbInformation, "Done"

End Sub



Private Sub pptFormat(xlCh As Chart, i As Integer)


'Formats the charts/pictures and the chart titles/textboxes.


Dim chTitle As String
Dim j As Integer
Dim tempName As String
Dim oLayout As CustomLayout
Dim counter As Integer

On Error Resume Next
'Get the chart title and copy the chart area.

xlCh.ChartArea.Copy

'Count the slides and add a new one after the last slide.
pptSlideCount = pptPres.Slides.Count
'tempName = GetLayout("Layout für QGs")

counter = i
'Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, Layout:=ppLayoutVerticalTitleAndTextOverChart)

pptApp.ActivePresentation.Slides(counter).Select
'pptApp.ActivePresentation.Slides(counter).Shapes.PasteSpecial DataType:=ppPasteOLEObject, link:=msoTrue
With pptApp.ActiveWindow
    .ViewType = ppViewNormal
    .View.PasteSpecial DataType:=ppPasteOLEObject, link:=msoTrue
End With

With pptApp.ActiveWindow.Selection.ShapeRange
    .LockAspectRatio = msoFalse
    'Oberer Rand 1 cm unter Standardtitel
    .Top = 3.92 * 28.38
    'Linker Rand 1.5 cm von linkem Folienrand
    .Left = 4.51 * 28.38
    'Eingefügte Tabelle auf Links und rechts 1,5 cm Rand skalieren
    .Width = 24.23 * 28.38
    'Bei Bedarf Höhe noch einstellen
    'Hier ist jedoch zu beachten, dass das Object skaliert wird !!!
    'Die Breite verändert sich dann
    .Height = 12.7 * 28.38
    .Line.Visible = msoFalse

End With

End Sub

Answer 1

Try using this code

Function PasteChartIntoSlide(theSlide As Object) As Object
    Sleep 100
    On Error Resume Next
    theSlide.Shapes.Paste.Select
    PPT.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
End Function

Function CopyChartFromExcel(theSlide As Object, cht As Chart) As Object
        cht.CopyPicture Appearance:=xlScreen, Format:=xlPicture, Size:=xlScreen
End Function

Function PositionChart(leftPos As Integer, rightPos As Integer, widthPos As Integer, heightPos As Integer) As Object
        Sleep 50
        PPT_pres.Windows(1).Selection.ShapeRange.Left = leftPos
        PPT_pres.Windows(1).Selection.ShapeRange.Top = rightPos
        PPT_pres.Windows(1).Selection.ShapeRange.Width = widthPos
        PPT_pres.Windows(1).Selection.ShapeRange.Height = heightPos
End Function


Function CopyPasteChartFull(Sld As Integer, cht As Chart, leftPos As Integer, rightPos As Integer, widthPos As Integer, heightPos As Integer) As Object
    If PPT Is Nothing Then Exit Function
    If PPT_pres Is Nothing Then Exit Function

    Dim mySlide As Object
    Dim myShape As Object

    PPT_pres.Slides(Sld).Select 'Pointless line, just lets the user see what is happening

    Set mySlide = PPT_pres.Slides(Sld)
    With mySlide
    .Select

    'copy chart
    CopyChartFromExcel mySlide, cht

    'Paste chart
    PasteChartIntoSlide mySlide

    'Position Chart
    PositionChart leftPos, rightPos, widthPos, heightPos

    End With

    'Clear The Clipboard
    Application.CutCopyMode = False

End Function