运行VBA脚本时会出现隐藏的动画

Question

我有一个powerpoint演示文稿，其中包含显示＆amp;隐藏形状。另外，我运行的VBA脚本会调整一些相同的形状。每当VBA脚本运行时，使用动画隐藏的所有形状都会出现并在脚本完成之前保持可见。

我总是可以改变我的所有动画来使用VBA脚本来设置形状的.Visible属性，但这看起来很麻烦并且消耗了大量代码。

有没有办法让VBA脚本动画一起工作？

提前致谢

以下是代码：

Private Type MyIntegerPoint
    x As Long
    y As Long
End Type

Private Type MySinglePoint
    x As Single
    y As Single
End Type

Private Type MyRect
    top As Single
    left As Single
    bottom As Single
    right As Single
End Type
Option Explicit
Private Declare PtrSafe Function GetCursorPos Lib "User32" (lpPoint As MyIntegerPoint) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "User32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function WindowFromPoint Lib "User32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare PtrSafe Function GetAsyncKeyState Lib "User32" (ByVal whichButton As Integer) As Integer

Public MousePt As MySinglePoint
Public StartPt As MySinglePoint
Public ShapeOrigCoord As MySinglePoint

Public InDrag As Boolean

Public Sub VerticalDragShape(ByRef sh As Shape)
    If Not InDrag Then
        InDrag = True
    End If

    ' initialize drag variables
    InitDragVars sh

    ActivePresentation.SlideShowWindow.View.State = ppSlideShowPaused
    While InDrag
        GetScaledMousePt
        DoEvents
        Dim keyState As Integer
        keyState = GetAsyncKeyState(1)
        If keyState < 0 Then
            InDrag = False
        Else
            With ActivePresentation.Windows(1).View.Slide
                .Shapes("Shape1").top = MousePt.y
                .Shapes("Shape1").left = MousePt.x
            End With
        End If
    Wend
    ActivePresentation.SlideShowWindow.View.State = ppSlideShowRunning
End Sub
Private Sub GetScaledMousePt()
    Dim mPt As MyIntegerPoint

    'Get the current raw mouse point
    GetCursorPos mPt

    'Convert it to point coordinates
    MousePt.x = MouseXCoordToPoints(mPt.x)
    MousePt.y = MouseYCoordToPoints(mPt.y)
End Sub

'   converts an x screen coordinate into document window coordinates
'   first, convert the screen pixels into slide show window coordinates
'   second, convert slide show window coordinates to document window coordinates
Public Function MouseXCoordToPoints(x As Long) As Single
    Dim slideWidth As Single
    Dim screenWidth As Single
    Dim fx As Single

    fx = x
    slideWidth = ActivePresentation.PageSetup.slideWidth
    screenWidth = GetSystemMetrics(0)

    MouseXCoordToPoints = fx * slideWidth / screenWidth

End Function
Public Function MouseYCoordToPoints(y As Long) As Single
    ' TRIAL 3
    Dim slideHeight As Single
    Dim screenHeight As Single
    Dim fy As Single

    fy = y
    slideHeight = ActivePresentation.PageSetup.slideHeight
    screenHeight = GetSystemMetrics(1)

    MouseYCoordToPoints = fy * slideHeight / screenHeight

End Function
Private Sub InitDragVars(ByRef sh As Shape)
    GetScaledMousePt                                    ' scale current mouse point
    StartPt = MousePt                                   ' save start mouse point
    ShapeOrigCoord.x = sh.left                          ' capture left coord of shape
    ShapeOrigCoord.y = sh.top                           ' capture top coord of shape
End Sub

要展示此问题，请创建包含两个形状的单个幻灯片演示文稿。在演示文稿Shape1＆amp;中命名形状。 Shape2。放置在演示模式下时，创建一个隐藏Shape2的动画。在Shape1上插入一个动作，以便在用鼠标单击时运行VerticalDragShape。运行演示文稿时，应隐藏Shape2。在Shape1上单击（并释放）鼠标应该使其随鼠标移动，直到再次单击。但是，当移动Shape1时，Shape2会再次变为可见，直到它变为隐藏时移动操作完成。