将动画效果从一种形状复制到另一种形状

Question

我正在尝试将动画效果从一种形状复制到另一种形状。

运动路径和淡入淡出效果抛出错误：

未找到方法/数据成员。

是否有其他方法可以通过 VBA 代码或任何其他库将一种形状的动画效果应用于其他形状？

Sub CopyAnimationsToSelectedShape1()
    Dim sourceShape As shape
    Dim targetShape As shape
    Dim sourceAnim As AnimationSettings
    Dim targetAnim As AnimationSettings

    ' Set the source shape
    Set sourceShape = ActivePresentation.Slides(1).Shapes("SourceShape") ' Replace with your source shape name

    ' Check if the source shape can be animated
    If sourceShape.HasTextFrame Then
        Set sourceAnim = sourceShape.AnimationSettings

        ' Check if exactly one shape is selected
        If ActiveWindow.Selection.Type = ppSelectionShapes And ActiveWindow.Selection.ShapeRange.Count = 1 Then
            Set targetShape = ActiveWindow.Selection.ShapeRange(1)
            Set targetAnim = targetShape.AnimationSettings

            ' Copy animation settings from the source to the target
            If sourceAnim.Animate = msoTrue Then
                targetAnim.Animate = msoTrue
                targetAnim.EntryEffect = sourceAnim.EntryEffect
                targetAnim.AdvanceMode = sourceAnim.AdvanceMode
                targetAnim.AdvanceTime = sourceAnim.AdvanceTime
                targetAnim.AfterEffect = sourceAnim.AfterEffect
                targetAnim.AnimationOrder = sourceAnim.AnimationOrder
                targetAnim.AnimateBackground = sourceAnim.AnimateBackground
                targetAnim.AnimateTextInReverse = sourceAnim.AnimateTextInReverse
                targetAnim.effectType = msoAnimEffectFade
                
                If sourceAnim.HasMotionPath Then
                    Set targetAnim.MotionEffect = sourceAnim.MotionEffect
                End If

            End If

            MsgBox "Animation settings copied from source to selected shape."
        Else
            MsgBox "Select one shape as the target."
        End If
    Else
        MsgBox "The source shape must have a text frame and animations."
    End If
    
    ActivePresentation.Slides(1).Shapes("SourceShape").Delete
End Sub

Answer 1

有趣的是，复制所有动画属性可能很复杂，但您可以使用 TimeLine 对象来复制运动路径。试试这个代码。

    Dim srcShape As Shape
    Dim tgtShape As Shape
    Dim srcSlide As Slide
    Dim tgtSlide As Slide

    ' Validate and get target shape
    Set tgtShape = ValidateAndGetTargetShape()
    If tgtShape Is Nothing Then Exit Sub

    ' Validate and get source shape
    Set srcShape = ValidateAndGetSourceShape(srcSlide)
    If srcShape Is Nothing Then Exit Sub

    ' Set slides
    Set srcSlide = ActivePresentation.Slides(ActiveWindow.View.Slide.SlideIndex)
    Set tgtSlide = srcSlide

    ' Copy Animations
    CopyAnimations srcSlide, srcShape, tgtSlide, tgtShape

    MsgBox "Animation settings copied from source to selected shape.", vbInformation, "Success"
End Sub

Function ValidateAndGetTargetShape() As Shape
    ' Check for selection
    If ActiveWindow.Selection.Type = ppSelectionNone Then
        MsgBox "No shape selected. Select one shape as the target.", vbExclamation, "Error"
        Exit Function
    End If

    ' Check if exactly one shape is selected
    If Not ActiveWindow.Selection.Type = ppSelectionShapes Or Not ActiveWindow.Selection.ShapeRange.Count = 1 Then
        MsgBox "Select exactly one shape as the target.", vbExclamation, "Error"
        Exit Function
    End If

    ' Return target shape
    Set ValidateAndGetTargetShape = ActiveWindow.Selection.ShapeRange(1)
End Function

Function ValidateAndGetSourceShape(srcSlide As Slide) As Shape
    Dim srcShapeName As String
    Dim srcShape As Shape
    
    ' Ask user to set the source shape
    srcShapeName = InputBox("Enter the name of the source shape:", "Set Source Shape")
    If srcShapeName = "" Then Exit Function

    ' Check if the source shape exists
    On Error Resume Next
    Set srcShape = srcSlide.Shapes(srcShapeName)
    On Error GoTo 0
    If srcShape Is Nothing Then
        MsgBox "The source shape was not found.", vbExclamation, "Error"
        Exit Function
    End If

    ' Check if source shape has a text frame
    If Not srcShape.HasTextFrame Then
        MsgBox "The source shape must have a text frame.", vbExclamation, "Error"
        Exit Function
    End If

    ' Return source shape
    Set ValidateAndGetSourceShape = srcShape
End Function

Sub CopyAnimations(ByRef srcSlide As Slide, ByRef srcShape As Shape, ByRef tgtSlide As Slide, ByRef tgtShape As Shape)
    Dim srcEffect As Effect
    Dim tgtEffect As Effect
    Dim i As Integer
    
    For i = 1 To srcSlide.TimeLine.MainSequence.Count
        Set srcEffect = srcSlide.TimeLine.MainSequence.Item(i)
        If srcEffect.Shape.Name = srcShape.Name Then
            Set tgtEffect = tgtSlide.TimeLine.MainSequence.AddEffect(Shape:=tgtShape, _
                                    effectId:=srcEffect.EffectType, _
                                    trigger:=msoAnimTriggerAfterPrevious, Index:=i)
            tgtEffect.Timing.Duration = srcEffect.Timing.Duration
        End If
    Next i
End Sub