Excel VBA创建PowerPoint演示文稿

Question

Looking for some help on updating a VBA Script that completes the following (basic algorithm):

1. Excel Template with formulas and macros creates a custom report consisting of approximately 30 charts
2. Macro called “CreatePowerPointPresentation” is used to transfer these charts into a specific PowerPoint template in specific format
3. The macros uses the slides contained in the template to create the first 6 slides
4. The macro then adds slides (transitions and content slides)

Note : This macro was actually created based on a feedback from this forum

This macro works great in Windows 7 with Office 2013, but generates errors in Windows 10, Office 2016 after slide 8 is created, randomly during one of the paste chart actions, but never gets past slide 10 of a 17-slide deck.

Errors:

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

Or

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

I'm not sure if this is an object issue or some other piece that I'm missing.

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

Answer 1

This sounds like the dreaded code-runaway scenario I have faced in PowerPoint before where it takes more time to copy things to and paste things from the Windows clipboard than the VBA code execution and hence the VBA code runs ahead and fails as a result. To confirm that this is the cause, put some break points on the .Copy, .ViewType and .PasteSpecial lines and see if it still fails for your full slide collection. If not, try adding some DoEvents lines after the .Copy and .ViewType lines and if that doesn't help, inject a Delay of one or two seconds instead of the DoEvents. That will at least confirm if the hypothesis is true or not.