复制/粘贴PowerPoint中的复选框(如果为True)

Question

我正在尝试复制所有幻灯片上的所有true或复选框，并将它们粘贴到演示文稿中的一张幻灯片上。我好像想不通。下面是我正在使用的代码。感谢您的帮助。

`Sub ckbxCopy()
Dim shp As Shape
Dim sld As Slide
Dim i As Integer
On Error Resume Next
For Each sld In ActivePresentation.Slides
For i = 1 To 4
shp = ActivePresentation.Slides("CheckBox" & CStr(i))
If Err.Number = 0 Then  ' shape exists
If shp.OLEFormat.Object.Value = True Then
shp.Copy
ActivePresentation.Slides(3).Shapes.Paste
End If
End If
Next i
Next sld
End Sub`

Answer 1

这对我有效：

Sub ckbxCopy()
Dim shp As Shape, pres As Presentation
Dim sld As Slide, sldDest As Slide
Dim i As Integer, t As Long

Set pres = ActivePresentation
Set sldDest = pres.Slides(3)    'where shapes are to be pasted

sldDest.Shapes.Range.Delete 'remove existing shapes
t = 20
For Each sld In pres.Slides
If sld.SlideIndex <> sldDest.SlideIndex Then
For i = 1 To 4
Set shp = Nothing
Set shp = SlideShape(sld, "CheckBox" & CStr(i))
If Not shp Is Nothing Then
If shp.OLEFormat.Object.Value = True Then
shp.Copy
pres.Slides(3).Shapes.Paste.Top = t 'paste and position
t = t + 20
End If
End If
Next i
End If
Next sld
End Sub
'Return a named shape from a slide (or Nothing if the shape doesn't exist)
Function SlideShape(sld As Slide, shapeName As String) As Shape
On Error Resume Next
Set SlideShape = sld.Shapes(shapeName)
End Function