The dreaded 80048240 error PowerPoint Generation from VBA Excel-CodePudding

I know there are other posts here on the subject but none of the answers suggested seem to do the trick. Therefore posting my first ever post here (after getting fantastic answers here for years).

So I am generating PowerPoint-slides from Excel,and I actually have a code to that works. Problem is, it takes ages to run! As you can see below I use the Wait 2 command in the script. The code only shows you 1 slide, I am generating 20 in the script. So far I have tried:

Changing Wait 2 to Wait 1
Replacing the Wait command with DoEvents

Both of those results in the below messages showing up at random places in the script.

Run-time Error '2147188160 (80048240): Shapes.PasteSpecial: Invalid Request. The specified data type is unavailable.

Sometimes however, when removing Wait, or changing to Wait 0.5 etc the script will run (!) and the slides will be completed in almost an instant. I do have a very fast and up-to-date laptop.

Would like this so be stable, and fast! isnt there any code I can add that just switches on/off the clipboard or something after each paste? Something that goes to the root of the problem.

This is the code from the first slide (slide 3) down to the start of slide 4, and as I say, it works..its just painfully slow.

   Sub Powerpoint2()

'Dim stuff

Dim rng As Range
Dim Powerpointapp As Object
Dim myPresentation As Object
Dim DestinationPPT As String
Dim myShape As Object
Dim mySlide As Object

Dim objApplication As Excel.Application
Dim objWorkbook As Workbook
Dim objWorksheet As Worksheet

Dim objWorksheet2 As Worksheet
Dim objWorksheet3 As Worksheet

Dim objShape As Shape
Dim objSlide As Slide
Dim objPresentation As Presentation

'Set stuff

Set objWorkbook = ThisWorkbook
Set objWorksheet = objWorkbook.Worksheets("Main")
Set objWorksheet2 = objWorkbook.Worksheets("Implementation")
Set objWorksheet3 = objWorkbook.Worksheets("Cat")

'Optimize Code
Application.ScreenUpdating = False

'Get PowerPoint Ready

'Create an Instance of PowerPoint
On Error Resume Next

'Set your destination path for the powerpoint presentation and open the file
Set Powerpointapp = CreateObject("Powerpoint.application")
DestinationPPT = (ActiveWorkbook.Path & ".\template.pptx")
Powerpointapp.Presentations.Open (DestinationPPT)

'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
    MsgBox "Powerpoint could not be found.aborting."
    Exit Sub
End If
On Error GoTo 0

'Set my current Powerpoint window as activated
Set myPresentation = Powerpointapp.ActivePresentation


'SLIDE 3  Start _________________________________________

Sheets("Main").Select
Sheets("Main").Activate

Call mainviewall
Call sort
Call hidedates
Call hideonhold

'Insert Main data_________________
'find last row of main column L

 Range("L65536").End(xlUp).Select
    Do Until Len(ActiveCell) > 0
        ActiveCell.Offset(-1, 0).Select
    Loop
MyLastCell = ActiveCell.Address

'Set range
Set rng = Worksheets("Main").Range("E2", ActiveCell.Address)

'Set which slide to paste into
Set mySlide = myPresentation.Slides(3)

'Copy Excel Range
rng.Copy
DoEvents
Wait 2

'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
Wait 2

'Set position:
myShape.Left = 60
myShape.Top = 80
myShape.Height = 500
myShape.Width = 700



'clear The Clipboard
Application.CutCopyMode = False

'copy the first chart__________________
objWorksheet.ChartObjects("Chart 11").Select
Selection.Copy
DoEvents
Wait 2


'paste chart to powerpoint
mySlide.Select
mySlide.Shapes.PasteSpecial DataType:=3
Wait 2

Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
 With myShape
          .Height = 150
          .Top = 380
          .Left = 750
        End With

'copy chart table___________________
Set rng = Worksheets("Main").Range("AC6:AG11")
Set mySlide = myPresentation.Slides(3)
rng.Copy
DoEvents
Wait 2


mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
Wait 2

'Set position:
myShape.Left = 60
myShape.Top = 400
myShape.Height = 100
myShape.Width = 300

'clear the clipboard
Application.CutCopyMode = False
'SLIDE 4  Start ____________________________________________________________________________

I also have this at the end for the "wait" to work:

Private Sub Wait(ByVal nSec As Long)
    nSec = nSec   Timer
    While nSec > Timer
        DoEvents
    Wend
End Sub

CodePudding user response：

Sometimes just trying again seems to work, so you can extract that into a separate method:

Set rng = Worksheets("Main").Range("AC6:AG11")
Set mySlide = myPresentation.Slides(3)
    
If Not CopyPasteOK(rng, mySlide.Shapes, 2) Then Exit Sub 'call copy/paste/try again
    
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

Method:

Function CopyPasteOK(objSource As Object, objDest As Object, pasteType As Long)
    Dim i As Long
    
    For i = 1 To 5 'try 5 times....
        objSource.Copy
        DoEvents
        On Error Resume Next
        objDest.PasteSpecial DataType:=pasteType
        If Err = 0 Then
            CopyPasteOK = True
            Exit For
        End If
        On Error GoTo 0
    Next i
    If Not CopyPasteOK Then 'warn on failure... EDITED
        MsgBox "Copy/Paste failed!", vbExclamation
    End If
End Function