excel 到 powerpoint Shapes.PasteSpecial DataType:=0 随机错误

Question

我遇到了一个 VBA 项目。我的目标是从 excel 制作一个幻灯片。 excel 中的每一行都制作一张新幻灯片，所有信息都会自动放置。

所有行都具有相同的列号。
工作簿中只有一个 sheet，所以 Activesheet.name 没问题。
我有随机顺序的图片和文字，这就是为什么我使用 ppPastedefault 作为形状类型的原因。
有些单元格可以为空，这就是我使用 on error.

程序启动，您选择了幻灯片模板。然后，对于 excel 第一行的每个单元格，将形状（文本或图片）放置在 powerpoint 幻灯片上所需的位置。位置保存在数组中。当第一行的所有形状都放入幻灯片后，它会自动制作所有其他幻灯片（所有形状都放置在正确的位置）。

这工作“很好”，但出现随机错误：

    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

我的程序有 2 个问题，我无法解决这些问题:

有时，形状（文本）不在文本框中，而是 table 形状，保持格式 excel。
有时，形状（文本或图片）丢失这完全是随机的。

关于其他主题，解决方案是：

在复制后放一个Doevents，这样不太好用。这可能会提高稳定性，但我仍然有错误。
放一个 Application.wait 1 或 2 秒，不起作用，这个解决方案对我来说不好。
在 shapes.pastespecial 之后放一个 Application.CutCopyMode = False，也不起作用。

我只能这样了。也许我对形状、幻灯片甚至对象的定义有问题 myShape 定义不当，但由于失败是随机的，因此很难控制。

有什么想法吗？

在此先感谢您的帮助，

Answer 1

如果有人遇到同样的问题，我认为这可以解决问题：

对于每个单元格，我检查它是否包含图片以及它是否为空。

如果包含图片，则复制DataType:=ppPasteDefault
如果不为空则复制带DataType:=ppPasteText
如果为空则复制DataType:=ppPasteEnhancedMetafile

所以循环遍历所有内容，甚至是空单元格，不再需要错误处理程序。

现在，如果 copy/paste 过程中出现错误，您可以使用错误处理程序重新启动循环。这不是最漂亮的解决方案，但到目前为止它是有效的。

但是，如果出现问题，程序将无限循环...您必须声明所有形状/对象/文本/图片并正确使用dataType:=。

`私有子 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

结束子`

谢谢，

excel 到 powerpoint Shapes.PasteSpecial DataType:=0 随机错误

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

powerpoint

vba

paste