総合テストパワポ 30枚の画像をランダム配置フェードアウトの終了アニメ動作付きオブジェクトの入れ替え設定手順と動作チェック PowerPointVBA

PowerPointのVBA マクロを使用して、
30枚の画像をランダムに入れ替え配置を行ってから、
スライドショーを実行。
単体で確認したマクロコードを組合わせて総合・結合テストを行いました。

www.youtube.com
https://www.youtube.com/watch?v=GXY_4b0YMtU&list=PL8vZhsyiiFhuBuPzw4CrOi0ysNAyCK8VH&index=1&pp=gAQBiAQB
目次
00:00 実行結果
01:53 1.やりたいこと
04:39 事前準備1.画像に名前を付ける
07:31 事前準備2.アニメーションを付ける
13:09 4.マクロで画像の入れ替えを行う
15:34 5.スライドショー実行のマクロをテスト
16:29 蛇足説明:移動しない画像を作る方法

1.やりたいこと 01:53 ～

知恵袋の質問に刺激を受けて、やってみました。
detail.chiebukuro.yahoo.co.jp
より

＞やりたいことは、
＞
＞＊１枚のスライドに３０枚の画像が並んでいる。
＞＊マクロを実行するたびに、その３０枚の画像がランダムに入れ替わる。
＞＊またアニメーションの設定で、
＞＋画像をクリックするとその画像のみがフェードで消える。
＞＋画面上の別のボタンをクリックするとすべての画像がフェードで消える。
＞
＞というものです。
＞画像を並べる。アニメーションを設定する。ところは手動でも構いません。
＞アニメーション効果を失うことなく、
＞画像がランダムに入れ替わるマクロを作ろうとしているのですが、中々うまくできません。

2.事前準備1.画像に名前を付ける 04:39 ～

＞＊１枚のスライドに３０枚の画像が並んでいる。

＞＋画面上の別のボタンをクリックするとすべての画像がフェードで消える。

を実現するために、
スライド内の画像に名前を付けます。

2.1 すべての画像がフェードで消えるトリガー画像に ALL消去 と名前を付けます
手作業で配置オブジェクトの選択と表示から
トリガー画像に ALL消去 と名前を付けます

2.2 ３０枚の画像に 移動画像1～30 と指定した名前を付けます。
手作業は大変なので、マクロで名前を変更します。

Option Explicit

'選択されたシェイプに名前を付ける 移動画像と名前を付ける
'入力された名前 + 連番にする
Sub pp2選択Shape名に移動画像と名前を付ける()

    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 objShape As PowerPoint.Shape 'シェイプ
    
    Dim strNewName As String   '新しくつける名前の頭文字
    strNewName = InputBox("名前の頭 XXXは？", "名前入力", "移動画像")
    If strNewName = "" Then
        MsgBox "処理を中止しました、キャンセルします"
        Exit Sub
    End If
    
    Dim n As Long
    For n = 1 To ActiveWindow.Selection.ShapeRange.Count '選択された数までループ
        Set objShape = ActiveWindow.Selection.ShapeRange(n) '←この選択されたシェイプの名前を変更
        objShape.Name = strNewName & n  '連番にする
        '頭0を付けたい時は = strNewName & Format(n, "000") などアレンジしてね
        DoEvents
    Next

    MsgBox "処理終了、配置 表示 から シェイプの名前を確認してください"
    DoEvents

End Sub

詳細は過去の単体テスト動画:
https://www.youtube.com/watch?v=YcbjdXfk94A&list=PL8vZhsyiiFhuBuPzw4CrOi0ysNAyCK8VH&index=4&pp=gAQBiAQB
↑を見てください。

3.事前準備2.アニメーションを付ける 07:31 ～

次に動作のアニメーションを付けます。

＞＊またアニメーションの設定で、
＞＋画像をクリックするとその画像のみがフェードで消える。
＞＋画面上の別のボタンをクリックするとすべての画像がフェードで消える。

これも、手作業だ大変なのでマクロを使います

'選択されたシェイプにアニメ効果を追加する
'個別のシェイプを押したらフェードアウトで消す
'And
'ALL消去 と名前の付いたシェイプで 全てフェードアウト
'フェードアウト 終了アニメの追加 サンプル
Sub pp3ALL消去で全て選択Shapeで個別にフェードアウト()
    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)  'プレゼンの下、スライドnページをセット
    
    'トリガーシェイプの用意
    Const strShpName = "ALL消去"  'ALL消去 と 名前を付けたトリガーシェイプを用意
    
    Dim objTriggerShape As Shape   'Const↑↓じゃなくて、直でよかったか？ぉぃぉぃ
    Set objTriggerShape = Nothing  '初期化、エラーチェックもかねて
    On Error Resume Next   '↓でSet 取得エラー時に次へ トリガー用Shpが無かったとき
    Set objTriggerShape = objSLD.Shapes(strShpName)
    On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
    '↑単純に、.Open "ファイル名" で開いただけです
    If objTriggerShape Is Nothing Then
        MsgBox "トリガー用の " & strShpName & " が見つからない。確認してください", vbExclamation
        Exit Sub
    End If
    
    'アニメ効果
    Dim objTimeLine As PowerPoint.TimeLine  'タイムラインって日本語だと？何だろう？
    Set objTimeLine = objSLD.TimeLine  'スライドの下にタイムラインがあります
  
    '↑このタイムラインにアニメ効果を追加していくイメージです
    Dim objEffect As PowerPoint.Effect  '効果
    Dim seqInteractive As PowerPoint.Sequence  'シーケンス 順序 : インタラクティブ？
    
    '複数選択の1個目～ アニメを追加、クリック時にする
    Dim n As Integer  'カウンター
    For n = 1 To ActiveWindow.Selection.ShapeRange.Count '選択された数までループ
        Set objShape = ActiveWindow.Selection.ShapeRange(n) '←このシェイプを↓アニメ効果を追加
        
        'インタラクティブ 双方向の順序を追加 (類似でいつも使っているのはMainSequence余談脱線)
        Set seqInteractive = objTimeLine.InteractiveSequences.Add(1) '順序の追加、新規順序

        '次に エフェクト 効果を追加 セット .AddTriggerEffectを使い
        '操作のシェイプobjShape, 効果はフェード, シェイプクリック時にトリガー, トリガーとなるシェイプ
        Set objEffect = seqInteractive.AddTriggerEffect( _
                            objShape, _
                            msoAnimEffectFade, _
                            msoAnimTriggerOnShapeClick, _
                            objTriggerShape)
        objEffect.Exit = msoTrue  '終了のアニメにする※ここで、終了セット
        'タイミングのセット
        objEffect.Timing.TriggerType = msoAnimTriggerWithPrevious '直前の動作と同時
        DoEvents
        Set objEffect = Nothing   '念のためクリア

        '個別をただ繰り返しただけ？
        '次に エフェクト 効果を追加 セット .AddTriggerEffectを使い
        '操作のシェイプobjShape, 効果はフェード, シェイプクリック時にトリガー, トリガーとなるシェイプ
        Set objEffect = seqInteractive.AddTriggerEffect( _
                            objShape, _
                            msoAnimEffectFade, _
                            msoAnimTriggerOnShapeClick, _
                            objShape)
        
        objEffect.Exit = msoTrue  '終了のアニメにする※ここで、終了セット
        DoEvents
        Set objEffect = Nothing   '念のためクリア
    Next

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

End Sub

詳細は過去の単体テスト動画:
https://www.youtube.com/watch?v=9PNq6QRLtZ0&list=PL8vZhsyiiFhuBuPzw4CrOi0ysNAyCK8VH&index=3&pp=gAQBiAQB
↑を見てください。

4.マクロで画像の入れ替えを行う 13:09 ～

＞＊マクロを実行するたびに、その３０枚の画像がランダムに入れ替わる。
を実現したいと思います。

＞2.2 ３０枚の画像に 移動画像1～30 と指定した名前を付けます。
で、移動画像 と名前を付けたので、

画像入れ替え用のマクロを使い画像を入れ替えます。

'シェイプの位置を入れ替える
'Const 画像頭文字 = "移動画像" の図形や画像、シェイプの
'.Topと.Leftを交換しただけ
Sub pp4画像名が移動画像のシェイプ位置を入れ替える()
    
    Dim nPAGE As Integer
    nPAGE = ActiveWindow.Selection.SlideRange.SlideIndex '現在選択しているページ
    
    Dim objSlide As PowerPoint.Slide  'スライド
    Set objSlide = ActivePresentation.Slides(nPAGE) '↑現在のページを変数に
    
    Dim objShape As PowerPoint.Shape  'シェイプ
    
    '100件分保存する、ReDim を使ってよ・・・オーバーしたらどうすんの？エラーかよ・・
    Dim shpNAME(100) As String  '名前、※同じ名前だと、マズイな・・・
    Dim shpX(100) As Double  '左上x座標
    Dim shpY(100) As Double  '左上y座標
    Dim shpCNT As Integer
    
    Const 画像頭文字 = "移動画像"   '※入れ替えたい画像の頭文字をセットする

    Dim MoveINDEX As Integer  '移動先
    Dim workX As Double  '一時保存 x,y
    Dim workY As Double
    
    '該当ShapeのName,x,yを保存しながら座標のみ入れ替える？
    'ループ前初期化
    shpCNT = 0     '0で初期化、使う前にcnt=cnt+1する
    For Each objShape In objSlide.Shapes  'スライド内のシェイプ達を一つ一つあさる
        '名前の規則 で 判断？
        If Left(objShape.Name, Len(画像頭文字)) = 画像頭文字 Then  '名前の頭文字で判断のルールとする？
            '情報を保存する
            shpCNT = shpCNT + 1
            shpNAME(shpCNT) = objShape.Name
            shpX(shpCNT) = objShape.Left
            shpY(shpCNT) = objShape.Top
        End If
    Next
    
    '↑うえで一つも引っかからなかった時、名前が違っていた時
    If shpCNT = 0 Then
        MsgBox "オブジェクト:[" & 画像頭文字 & "]が見つかりません、確認してね", vbExclamation
        Exit Sub  '途中退場
    End If

    '乱数Rndを使い、座標数値を入れ替える
    Dim n As Long
    For n = 1 To shpCNT
        '移動先:自分を含めた乱数を生成する※同じ数値が出るけど、こだわらなければ・・・
        MoveINDEX = Int((shpCNT * Rnd) + 1)   '1～shpCNTまでの値で移動先を生成する
        'x,yの座標を入れ替える MoveINDEX → Work , n → MoveINDEX, Work → n
        Debug.Print n & "→" & MoveINDEX
        workX = shpX(MoveINDEX)  '移動先を保存して
        workY = shpY(MoveINDEX)
        shpX(MoveINDEX) = shpX(n)  '移動する、まだ配列上
        shpY(MoveINDEX) = shpY(n)
        shpX(n) = workX   '一時保存値をセットして交換
        shpY(n) = workY
    Next
    
    '上で交換した座標、保存した位置をセット
    For n = 1 To shpCNT
        Set objShape = objSlide.Shapes(shpNAME(n)) '保存した名前でアクセスする
        objShape.Left = shpX(n)
        objShape.Top = shpY(n)
    Next n
    
    DoEvents
    
    MsgBox "終了、移動を確認してください"
    
End Sub

詳細は過去の単体テスト動画:
https://www.youtube.com/watch?v=nrEzOnGEsZk&list=PL8vZhsyiiFhuBuPzw4CrOi0ysNAyCK8VH&index=2&pp=gAQBiAQB
↑を見てください。

5.スライドショー実行のマクロをテスト 15:34 ～

おまけで、
スライドショー実行のマクロをテストしてみます。

'オリジナルの画像入れ替えマクロを実行してから
'スライドショーを実行してみる。
Sub pp5画像入れ替え後にスライドショー実行()

    Call pp4画像名が移動画像のシェイプ位置を入れ替える
    DoEvents
    
    Dim nPAGE As Integer
    nPAGE = ActiveWindow.Selection.SlideRange.SlideIndex '現在選択しているページ
    
    ActivePresentation.SlideShowSettings.Run  'スライドショーの実行 F5的なヤツ
    
    SlideShowWindows(1).View.GotoSlide nPAGE  'View.GotoSlide で現在ページに移動する
  
End Sub