Excel VBA创建PowerPoint演示文稿

寻找有关更新完成以下（基本算法）的VBA脚本的一些帮助：

• 包含公式和宏的Excel模板创建一个包含大约30个图表的自定义报告

• 名为“CreatePowerPointPresentation”的宏用于将这些图表以特定格式传输到特定的PowerPoint模板

• 宏使用模板中包含的幻灯片创建前6张幻灯片

• 然后宏添加幻灯片（转场和内容幻灯片）

Note ：此宏实际上是根据此论坛的反馈创建的

此宏在带有Office 2013的Windows 7中运行良好，但在创建幻灯片8之后，在其中一个粘贴图表操作期间随机生成了Windows 10，Office 2016中的错误，但从未超过17张幻灯片的幻灯片10 .

Errors:

Runtime Error '-2147188160 (80048240)
Method 'PasteSpecial'of object 'Shapes' failed.

要么

Runtime Error '-2147023170 (800706be)':
Automation Error 
The Remote procedure call failed.

我不确定这是一个对象问题还是我遗失的其他一些内容 .

Code below:

Sub CreatePowerPointPresentation()
'=========================================================================
'Create PowerPoint Presentation
'Assigned to Index Tab
'==========================================================================


        Dim newPowerPoint As PowerPoint.Application
        Dim activeSlide As PowerPoint.Slide
        Dim CHT As Excel.ChartObject
        Dim fmt As String
        Dim hgt As String
        Dim wth As String


‘this code allows for the user to select whether to paste the charts as Excel Charts or PNG Formatted images.

Sheets("Index").Select
            If Range("AB7").Value = "Excel Charts" Then
                fmt = ppPasteDefault
            Else
                fmt = ppPastePNG
            End If

   'Establishes the global height and width of the graphics or charts pasted from Excel
        hgt = 280
        wth = 710

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

    '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

           'Show the PowerPoint
            newPowerPoint.Visible = True
            Application.EnableEvents = True
            Application.ScreenUpdating = True

           'Apply Template & Create Title Slide 1

             newPowerPoint.ActivePresentation.ApplyTemplate Application.DefaultFilePath & "\file.potx"

            'Set presentation to be 16x9
            'AppActivate ("Microsoft PowerPoint")
                With newPowerPoint.ActivePresentation.PageSetup
                .SlideSize = ppSlideSizeOnScreen16x9
                .FirstSlideNumber = 1
                .SlideOrientation = msoOrientationHorizontal
                .NotesOrientation = msoOrientationVertical
               End With
'Create Slides 2-6 these are imported from the template
newPowerPoint.ActivePresentation.Slides.InsertFromFile Application.DefaultFilePath & "\File.potx", 0, 1

'Create Slide 7

newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutBlank
newPowerPoint.ActivePresentation.Slides(7).CustomLayout = newPowerPoint.ActivePresentation.SlideMaster.CustomLayouts(33)
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)

With newPowerPoint.ActivePresentation.Slides(7)
                .Shapes("Title 1").TextFrame.TextRange.Text = "Title1"
End With
            newPowerPoint.ActiveWindow.ViewType = ppViewSlide

‘Create Slide 8 – Quad Chart Slide

newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutBlank
newPowerPoint.ActivePresentation.Slides(8).CustomLayout = newPowerPoint.ActivePresentation.SlideMaster.CustomLayouts(13)
newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
newPowerPoint.ActivePresentation.Slides(8).Shapes("Title 1").TextFrame.TextRange.Text = "Title 1"
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
newPowerPoint.ActiveWindow.ViewType = ppViewSlide

        'Upper Left
            Sheets("Charts").Select
            ActiveSheet.ChartObjects("Chart 3").Select
            ActiveChart.ChartArea.Copy
            newPowerPoint.ActiveWindow.ViewType = ppViewSlide
            activeSlide.Shapes.PasteSpecial(DataType:=fmt).Select

          'Adjust the positioning of the Chart on Powerpoint Slide
           newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 5
           newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 75
           newPowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
           newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 145
           newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 345

        'Upper Right
            Sheets("Charts").Select
            ActiveSheet.ChartObjects("Chart 2").Select
            ActiveChart.ChartArea.Copy
            newPowerPoint.ActiveWindow.ViewType = ppViewSlide
            activeSlide.Shapes.PasteSpecial(DataType:=fmt).Select

           newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 350
           newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 75
           newPowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
           newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 145
           newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 345


        'Lower Left
            Sheets("Charts").Select
            ActiveSheet.ChartObjects("Chart 4").Select
            ActiveChart.ChartArea.Copy
            newPowerPoint.ActiveWindow.ViewType = ppViewSlide
            activeSlide.Shapes.PasteSpecial(DataType:=fmt).Select

            newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 5
            newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 230
            newPowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
            newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 145
            newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 690


‘More slides……

    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Set activeSlide = Nothing
    Set newPowerPoint = Nothing

End Sub