【PowerPoint VBA】大量の図形に「クリックで消える」アニメを一括設定！AddTriggerEffect活用術

【PowerPoint VBA】大量の図形に一括設定！クリックで消えるパネルやクイズを自動作成する方法

パワーポイントで「クリックした図形が消える」という設定を大量の図形に行うとき、1つずつ手作業で設定して発狂しそうになったことはありませんか？
今回は、VBA（マクロ）を使って、クリックした図形がフェードアウトする「終了動作」を一括で自動設定する方法を備忘録としてまとめます。

[00:00](https://www.youtube.com/watch?v=9PNq6QRLtZ0&t=0s) やりたいこと、実行結果のデモ

1. アニメーションの「2つのシーケンス」を理解する

PowerPointのアニメーションタイムラインには、大きく分けて2つの種類があります。

''MainSequence（メイン・シーケンス）''：クリックするたびに順番通りに実行される通常のアニメ。
''InteractiveSequences（インタラクティブ・シーケンス）''：特定の図形をクリックした時にだけ動作する「トリガー設定」。

今回は、この「インタラクティブ・シーケンス」をVBAで操作して、効率化を図ります。

[00:43](https://www.youtube.com/watch?v=9PNq6QRLtZ0&t=43s) TimeLineのMainSequenceとInteractiveSequences違い

2. 選択した図形を「自分自身をクリックして消える」ようにする

まずは、選択した複数の図形それぞれに「自分自身をクリックしたらフェードアウト（終了）する」設定を一括で行うコードです。

'選択されたシェイプにアニメ効果を追加する
'自分自身が押されたら、自身を消す（終了アニメ）を追加
Sub pp選択Shapeにフェードアウトを追加_1個別にアニメ追加()

    If ActiveWindow.Selection.Type <> ppSelectionShapes Then
        MsgBox "Shape図形やテキストボックスを選択してね"
        Exit Sub
    End If
    
    If ActiveWindow.Selection.ShapeRange.Count = 0 Then
        MsgBox "Shape図形やテキストボックスを選択してね"
        Exit Sub
    End If

    Dim nPAGE As Integer
    Dim objSLD As PowerPoint.Slide
    Dim objShape As PowerPoint.Shape
    
    nPAGE = ActiveWindow.Selection.SlideRange.SlideIndex
    Set objSLD = ActivePresentation.Slides(nPAGE)
    
    'タイムラインを取得
    Dim objTimeLine As PowerPoint.TimeLine
    Set objTimeLine = objSLD.TimeLine
  
    Dim objEffect As PowerPoint.Effect
    Dim seqInteractive As PowerPoint.Sequence
    
    '選択された各シェイプに対してループ処理
    Dim n As Integer
    For n = 1 To ActiveWindow.Selection.ShapeRange.Count
        Set objShape = ActiveWindow.Selection.ShapeRange(n)
        
        'インタラクティブ・シーケンスを追加
        Set seqInteractive = objTimeLine.InteractiveSequences.Add(1)

        'AddTriggerEffect(対象図形, 効果, トリガーの種類, トリガーとなる図形)
        Set objEffect = seqInteractive.AddTriggerEffect( _
                            objShape, _
                            msoAnimEffectFade, _
                            msoAnimTriggerOnShapeClick, _
                            objShape)
        
        'ここがポイント：終了アニメーションにする
        objEffect.Exit = msoTrue 

    Next

    MsgBox "処理終了、アニメーションウィンドウで確認してください"
End Sub

重要なプロパティ

''objEffect.Exit = msoTrue''：これを設定することで「表示（イン）」ではなく「消去（アウト）」のアニメーションになります。

[04:25](https://www.youtube.com/watch?v=9PNq6QRLtZ0&t=265s) マクロでエフェクト効果のフェードを追加
[06:00](https://www.youtube.com/watch?v=9PNq6QRLtZ0&t=360s) Effect.Exit = msoTrue でフェードアウトに切り替え

3. 「一括削除ボタン」と「個別消去」を組み合わせる（結合テスト）

次に、個別に消すだけでなく「特定のボタン（例：削除全て）を押したときに全ての図形を一気に消す」というハイブリッドな設定です。

'個別クリックでフェードアウト ＋ 「削除全て」ボタンで全消去
Sub pp選択Shapeにフェードアウトを追加_3結合テスト()
    If ActiveWindow.Selection.Type <> ppSelectionShapes Then Exit Sub

    Dim nPAGE As Integer
    Dim objSLD As PowerPoint.Slide
    Dim objShape As PowerPoint.Shape
    nPAGE = ActiveWindow.Selection.SlideRange.SlideIndex
    Set objSLD = ActivePresentation.Slides(nPAGE)
    
    'トリガーとなるシェイプの名前を指定
    Const strShpName = "削除全て" 
    Dim objTriggerShape As Shape
    On Error Resume Next
    Set objTriggerShape = objSLD.Shapes(strShpName)
    On Error GoTo 0
    
    If objTriggerShape Is Nothing Then
        MsgBox "トリガー用の " & strShpName & " が見つかりません"
        Exit Sub
    End If
    
    Dim objTimeLine As PowerPoint.TimeLine: Set objTimeLine = objSLD.TimeLine
    Dim objEffect As PowerPoint.Effect
    Dim seqInteractive As PowerPoint.Sequence
    
    Dim n As Integer
    For n = 1 To ActiveWindow.Selection.ShapeRange.Count
        Set objShape = ActiveWindow.Selection.ShapeRange(n)
        
        Set seqInteractive = objTimeLine.InteractiveSequences.Add(1)

        '1. 一括削除ボタン用のトリガー設定
        Set objEffect = seqInteractive.AddTriggerEffect( _
                            objShape, msoAnimEffectFade, _
                            msoAnimTriggerOnShapeClick, objTriggerShape)
        objEffect.Exit = msoTrue
        'ここがポイント：ボタンを押したときに全員同時に消えるよう設定
        objEffect.Timing.TriggerType = msoAnimTriggerWithPrevious 

        '2. 自分自身をクリックした時のトリガー設定
        Set objEffect = seqInteractive.AddTriggerEffect( _
                            objShape, msoAnimEffectFade, _
                            msoAnimTriggerOnShapeClick, objShape)
        objEffect.Exit = msoTrue
    Next

    MsgBox "結合テスト完了！"
End Sub

[08:58](https://www.youtube.com/watch?v=9PNq6QRLtZ0&t=538s) 選択図形・シェイプ全てをフェードアウトする
[12:06](https://www.youtube.com/watch?v=9PNq6QRLtZ0&t=726s) 直前の動作と同時の設定（TriggerWithPrevious）について