Search code examples
vbapowerpointpaste

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

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,

Solution

  • In case someone has the same issue, I think this solve the problem :

    1. 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.

    1. 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,