Excel宏-如何在已经打开的PPT中粘贴Excel图表

Question

我有一个已经打开的ppt，我正在尝试从Worksheet = PivotChart将excel图表粘贴到其中。以下代码无法正常工作。这是由一位无法解决的资深人士提供给我的。我无法解决问题。

'---------------------- PPT创建---------------------'

   'First we declare the variables we will be using
    Dim newPowerPoint As PowerPoint.Application
    Dim activeSlide As PowerPoint.Slide
    Dim cht As Excel.ChartObject
    Dim XLApp As Excel.Application

 'Look for existing instance
    On Error Resume Next
    Set newPowerPoint = GetObject(, "PowerPoint.Application")
    On Error GoTo 0

'Let's create a new PowerPoint
    If newPowerPoint Is Nothing Then
        Set newPowerPoint = New PowerPoint.Application
    End If
'Make a presentation in PowerPoint
    If newPowerPoint.Presentations.Count = 0 Then
        newPowerPoint.Presentations.Add
    End If

'Title Slide
    newPowerPoint.Visible = True
    newPowerPoint.ActivePresentation.Slides.Add 
 newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
        newPowerPoint.ActiveWindow.View.GotoSlide 
 newPowerPoint.ActivePresentation.Slides.Count
        Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
        activeSlide.Shapes(1).TextFrame.TextRange.Text = "AUTOMATED TICKET ANALYSIS"

            Set XLApp = GetObject(, "Excel.Application")
            XLApp.Range("Y66:Z77").Select
            XLApp.Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
            activeSlide.Shapes.Paste.Select

'Adjust the positioning of the Chart on Powerpoint Slide
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 60
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 200

        activeSlide.Shapes(3).Width = 500
        activeSlide.Shapes(2).Width = 300
        activeSlide.Shapes(2).Left = 600

 XLApp.Range("AR100").Select
        XLApp.Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
        activeSlide.Shapes.Paste.Select
' Adjust the positioning of text box
            newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 580
            newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 200

'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
    For Each cht In ActiveSheet.ChartObjects

    'Add a new slide where we will paste the chart
        newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
        newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
        Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)

    'Copy the chart and paste it into the PowerPoint as a Metafile Picture
        cht.Select
        ActiveChart.ChartArea.Copy

activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select


'Set the title of the slide the same as the title of the chart
        activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text

 'Adjust the positioning of the Chart on Powerpoint Slide
            newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 80
            newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 150

        activeSlide.Shapes(3).Width = 500
        activeSlide.Shapes(2).Width = 300
        activeSlide.Shapes(2).Left = 600

   Next
'HeatMap getting pasted to new slide
            newPowerPoint.ActivePresentation.Slides.Add 
newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
            newPowerPoint.ActiveWindow.View.GotoSlide 
newPowerPoint.ActivePresentation.Slides.Count
            Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)

Set XLApp = GetObject(, "Excel.Application")
XLApp.Range("M65:U90").Select
XLApp.Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
activeSlide.Shapes.Paste.Select

'Adjust the positioning of the Chart on Powerpoint Slide
            newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 380
            newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 90

        activeSlide.Shapes(3).Width = 500
        activeSlide.Shapes(2).Width = 300
        activeSlide.Shapes(2).Left = 600

  activeSlide.Shapes(1).TextFrame.TextRange.Text = "HEAT MAP"

   ' End Slide
newPowerPoint.ActivePresentation.Slides.Add 
newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
            newPowerPoint.ActiveWindow.View.GotoSlide 
newPowerPoint.ActivePresentation.Slides.Count
            Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
            activeSlide.Shapes(1).TextFrame.TextRange.Text = "Thank You!"


'AppActivate ("Microsoft PowerPoint")'
    Set activeSlide = Nothing
    Set newPowerPoint = Nothing