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

Question

我在VBA工程中遇到了麻烦。我的目标是用excel制作一个PPT。excel中的每一行都会制作一张新的幻灯片，所有信息都会自动放置。

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

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

这是有效的"；"好"；，但出现了随机错误：

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

我的程序有两个问题，我无法解决：

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

在其他主题上，解决方案包括：

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

这就是我所能做的。也许我对形状、幻灯片的定义有问题，甚至对象myShape定义不好，但由于失败是随机的，这很难控制。

知道吗？

提前感谢您的帮助，

Answer 1

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

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

• 如果包含图片，则使用DataType:=ppPasteDefault进行复制
• 如果不为空，则使用DataType:=ppPasteText进行复制
• 如果为空，则使用DataType:=ppPasteEnhancedMetafile进行复制

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

2. 现在，如果复制/粘贴过程中出现错误，您可以使用错误处理程序重新启动循环。这不是最漂亮的解决方案，但到目前为止，它正在发挥作用

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

`专用子命令按钮1_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

结束子`

谢谢，