excel to powerpoint Shapes.PasteSpecial DataType:=0 random error - vba

Question

I am having trubbles with a VBA project. My goal is to make a powerpoint from an excel. Each line in the excel make a new slide, and all info are automatically placed.
All rows have the same column number.
Only one sheet in workbook, so no problem with Activesheet.name.
I have pictures and text in random order, this is why I used ppPastedefault for the type of the shape.
Some cells can be empty, this is why I used the on error.
Program launch, you chose the slide template. Then, fo each cells of the first row from excel, you place the shape (text or picture) where you want on the powerpoint slide. Positions are saved in arrays. When all shapes from the first row are placed into the slide, it automatically make all the others slides (all shapes are placed in good position).
this is working "fine", but random errors appears :
Private Sub CommandButton1_Click()
Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.slide
Dim Wks As Worksheet
Dim Ncol As Integer, Nrow As Integer, Y As Integer
Dim ExcRng As Variant, Tpath As Variant, Plage As Variant
Dim PLShape() As Variant, PTShape() As Variant, PHShape() As Variant
Dim myShape As Object
Set Wks = Sheets(ActiveSheet.Name)
Set PPTApp = New PowerPoint.Application
PPTApp.Visible = True
Set PPTPres = PPTApp.Presentations.Add
'define row, column and choice of the ppt layout. Also dimensioning the Arrays'
Ncol = Wks.Cells(1, Columns.Count).End(xlToLeft).Column
Nrow = Wks.Cells(Rows.Count, "B").End(xlUp).Row
Set Plage = Wks.Range("B1:B" & Nrow)
Tpath = Application.GetOpenFilename(".potx,*.potx", , "Choisissez le template")
Y = 0
ReDim PTShape(Ncol - 1)
ReDim PLShape(Ncol - 1)
ReDim PHShape(Ncol - 1)
For Each Cell In Plage
'Loop through all rows'
Set PPTSlide = PPTPres.Slides.Add(Y + 1, ppLayoutBlank)
With PPTSlide
PPTSlide.ApplyTemplate (Tpath)
PPTSlide.CustomLayout = PPTPres.SlideMaster.CustomLayouts(1)
End With
Y = Y + 1
'Loop through all columns of each rows'
For x = 0 To Ncol - 1
Set ExcRng = Wks.Cells(Cell.Row, x + 1)
'On error is used to pass cells that are empty. Maybe I could test ExcRng instead, but can't make it work'
On Error GoTo suite:
'the problem should be around here i guess'
ExcRng.Copy
DoEvents
PPTSlide.Shapes.PasteSpecial DataType:=0
Set myShape = PPTSlide.Shapes(PPTSlide.Shapes.Count)
'If statement, if this is the first slide, then you place all shape one by one. If not, all shapes are placed automatically with, "copying" the first slide'
If Y = 1 Then
MsgBox "Enregistrer position"
PTShape(x) = myShape.Top
PLShape(x) = myShape.Left
PHShape(x) = myShape.Height
Else
myShape.Top = PTShape(x)
myShape.Left = PLShape(x)
myShape.Height = PHShape(x)
End If
suite:
On Error GoTo -1
Application.CutCopyMode = False
Next x
Next Cell
End Sub
I have 2 issues with the program, and i can't solve those :
sometime, the shape (text) are not in a textbox but are in a table shape, keeping format from excel.
sometime, shapes (both text or picture) are missing
This is completly random.
On other topics, solutions are :
put a Doevents after the copy, this is not working very well. This might have improve stability, but I still have errors.
put a Application.wait for 1 or 2 seconde, not working and this solution is not good for me.
put a Application.CutCopyMode = False after the shapes.pastespecial, also not working.
That's all I could do. Maybe I have a problem into the definition of shapes,slides or even the object myShapeis badly defined, but as the failure is random, this is very hard to control.
Any idea ?
Thanks in advance for the help,

Answer 1

In case someone has the same issue, I think this solve the problem :
For each cell, I check if it contains picture and if it is empty or not.
If it contains a picture, it is copied with DataType:=ppPasteDefault
If it is not empty, it is copied with DataType:=ppPasteText
If it is empty, it is copied with DataType:=ppPasteEnhancedMetafile
So the loop go through everything, even empty cells and does not need the error handler anymore.
Now, you can use the error handler to restart the loop if there is an error in the copy/paste process. This is not the most beautiful solution, but it is working so far.
However, if something is going wrong, the program will loop indefinitely... you have to declare all your shapes / object / text / picture well and use dataType:= correctly.
`Private Sub CommandButton1_Click()
Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.slide
Dim cshape As Shape
Dim cflag As Boolean
Dim Wks As Worksheet
Dim Ncol As Integer, Nrow As Integer, Y As Integer
Dim ExcRng As Variant, Tpath As Variant, Plage As Variant
Dim PLShape() As Variant, PTShape() As Variant, PHShape() As Variant
Dim myShape As Object
Dim Eshape As Shape
Set Wks = Sheets(ActiveSheet.Name)
Set PPTApp = New PowerPoint.Application
PPTApp.Visible = True
Set PPTPres = PPTApp.Presentations.Add
Ncol = Wks.Cells(1, Columns.Count).End(xlToLeft).Column
Nrow = Wks.Cells(Rows.Count, "B").End(xlUp).Row
Set Plage = Wks.Range("B1:B" & Nrow)
Tpath = Application.GetOpenFilename(".potx,*.potx", , "Choisissez le template")
Y = 0
ReDim PTShape(Ncol - 1)
ReDim PLShape(Ncol - 1)
ReDim PHShape(Ncol - 1)
On Error GoTo reprise:
For Each Cell In Plage
Set PPTSlide = PPTPres.Slides.Add(Y + 1, ppLayoutBlank)
'DoEvents'
With PPTSlide
PPTSlide.ApplyTemplate (Tpath)
PPTSlide.CustomLayout = PPTPres.SlideMaster.CustomLayouts(1)
'DoEvents'
End With
Y = Y + 1
For x = 0 To Ncol - 1
reprise:
On Error GoTo -1
Set ExcRng = Wks.Cells(Cell.Row, x + 1)
'DoEvents'
ExcRng.Copy
DoEvents
cflag = False
For Each cshape In Wks.Shapes
If cshape.TopLeftCell.Address = Wks.Cells(Cell.Row, x + 1).Address Then
cflag = True
GoTo suite:
End If
Next
suite:
If cflag Then
PPTSlide.Shapes.PasteSpecial DataType:=ppPasteDefault
'DoEvents'
Else
If Wks.Cells(Cell.Row, x + 1) <> 0 Then
PPTSlide.Shapes.PasteSpecial DataType:=ppPasteText
'DoEvents'
Else
PPTSlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
'DoEvents'
End If
End If
Set myShape = PPTSlide.Shapes(PPTSlide.Shapes.Count)
If Y = 1 Then
MsgBox "Enregistrer position"
PTShape(x) = myShape.Top
PLShape(x) = myShape.Left
PHShape(x) = myShape.Height
Else
myShape.Top = PTShape(x)
myShape.Left = PLShape(x)
myShape.Height = PHShape(x)
'DoEvents'
End If
Application.CutCopyMode = False
Next x
Next Cell
End Sub`
Thanks,