PPT VBA例程在步骤模式下工作，但在运行中不行

Question

我尝试在幻灯片上使用选定的图片，然后复制/粘贴 （我不能从文件加载图片，必须来自幻灯片本身。）< /em>

当我使用 f8 逐步浏览代码时，它可以正常工作。但是当我运行宏时，占位持有人会空虚。

我试图设定延迟以给PPT足够的时间，但是无论我有多高的延迟，它都无法正常工作（占位持有人都不会填补）

任何想法，什么可能导致这种奇怪的行为？更好的想法如何将所选图像放入模板占位符中（尽管也应该在Mac上使用）。谢谢您的宝贵时间！

Sub SetImageIntoPlaceholder()
    Dim sImage As Shape
    Dim iSl As Integer
    Dim oSl As Slide
    Dim oPl As Shape
    On Error GoTo ErrorHandler

    If ActiveWindow.Selection.ShapeRange().Count <> 1 Then
        MsgBox "Please select only the picture you wish to place in the Placeholder", vbOKOnly Or vbCritical, Application.Name
        Exit Sub
    End If
    
    iSl = ActiveWindow.View.Slide.SlideIndex
    Set oSl = ActivePresentation.Slides(iSl)
    Set sImage = ActiveWindow.Selection.ShapeRange(1)
    sImage.Copy
    
    For Each oPl In oSl.Shapes
        If oPl.Type = msoPlaceholder Then
            With oPl
                Select Case oPl.PlaceholderFormat.Type
                    Case Is = 18
                        'Its a picture placeholder
                        Delay 4
                        oPl.Select
                        Delay 4
                        ActiveWindow.View.Paste
                        Delay 5
                        'oSl.Shapes.Paste
                        Application.CommandBars.ExecuteMso ("SlideReset")
                        'Delay 1.5
                        'sImage.Delete
                        Exit Sub
            
                    Case Else
                        ' ignore other shape types
                End Select
            End With
        End If
    Next oPl
    
ErrorHandler:
    'Resume Next
End Sub

Answer 1

复制后和粘贴后，尝试添加doevents。另外，尝试将副本和粘贴操作分为单独的过程。 VBA应等到操作完成后，才能进入和退出程序。我没有测试过，但是也许是这样的。 。 。

Option Explicit

Sub SetImageIntoPlaceholder()
    Dim sImage As Shape
    Dim iSl As Integer
    Dim oSl As Slide
    On Error GoTo ErrorHandler

    If ActiveWindow.Selection.ShapeRange().Count <> 1 Then
        MsgBox "Please select only the picture you wish to place in the Placeholder", vbOKOnly Or vbCritical, Application.Name
        Exit Sub
    End If
    
    iSl = ActiveWindow.View.Slide.SlideIndex
    Set oSl = ActivePresentation.Slides(iSl)
    Set sImage = ActiveWindow.Selection.ShapeRange(1)
    sImage.Copy
    
    DoEvents
    
    PastePictureInSlide oSl
    
ErrorHandler:
    'Resume Next
End Sub

Private Sub PastePictureInSlide(ByVal oSl As Slide)

    Dim oPl As Shape
    
    For Each oPl In oSl.Shapes
        If oPl.Type = msoPlaceholder Then
            With oPl
                Select Case .PlaceholderFormat.Type
                    Case Is = 18
                        'Its a picture placeholder
                        .Select
                        ActiveWindow.View.Paste
                        'oSl.Shapes.Paste
                        Application.CommandBars.ExecuteMso ("SlideReset")
                        DoEvents
                        Exit Sub
                    Case Else
                        ' ignore other shape types
                End Select
            End With
        End If
    Next oPl

End Sub