パワポ スライド内 画像表示位置を入れ替え 単純に.Left .Topで位置を入れ替えシャッフル

毎回プレゼン前に
スライド内の画像をシャッフル、ランダムで入れ替えたい。
そんな処理を依頼されたら？

なんで？そんなこと・・と、理由を知りたくなるけど、
そんなことは、置いといて、
youtu.be
https://youtu.be/nrEzOnGEsZk
目次
00:00 やりたいこと 実行結果
01:39 1.仕様・ルールを決める 2.名前を変更してもらう
02:59 3.テスト実行から
03:50 4.コードと簡単な説明
08:49 5.画像の名前を変える事前準備の方が大変なのでツールを提供
10:28 入れ替え、交換の仕掛けを説明
13:34 6.終わりの挨拶

1.仕様・ルールを決める

画像を入れ替えたいので、ルールを決めます。

マクロで、
Const 画像頭文字 = "交換画像" '※入れ替えたい画像の頭文字をセットする
交換画像 のオブジェクトを入れ替える仕様で作成します。

2.スライドの画像 名前を変更してもらう

スライドの画像が 図 99 とついている名前を
交換画像999と名前を付けてもらいます。

※大変なので、名前付けマクロも作成して、提供する・・・

3.テスト実行から

コードの説明は、置いといて、
テスト実行する。

4.コードと簡単な説明

Const 画像頭文字 = "交換画像"
で反応するオブジェクトのルールを定義

チェック・判断は

'名前の規則 で 判断？
If Left(objShape.Name, Len(画像頭文字)) = 画像頭文字 Then  '名前の頭文字で判断のルールとする？
左側の文字列が一致するか？If文で判断して、

.Topと.Leftをほぞん。
'情報を保存する
shpCNT = shpCNT + 1
shpNAME(shpCNT) = objShape.Name
shpX(shpCNT) = objShape.Left
shpY(shpCNT) = objShape.Top

あとは、
座標を入れ替えて
再セットして、
動いたように見せかけただけのコードです。

'シェイプの位置を入れ替える
'Const 画像頭文字 = "交換画像" の図形や画像、シェイプの
'.Topと.Leftを交換しただけ
Sub シェイプの位置を入れ替えるテスト0602()
    
    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を保存しながら座標のみ入れ替える？
    Debug.Print "Id", "Name", "Type"
    'ループ前初期化
    shpCNT = 0     '0で初期化、使う前にcnt=cnt+1する
    For Each objShape In objSlide.Shapes  'スライド内のシェイプ達を一つ一つあさる
        Debug.Print objShape.Id, objShape.Name, objShape.Type
        '名前の規則 で 判断？
        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

5.画像の名前を変える事前準備の方が大変なのでツールを提供

プログラマーさんやお偉方は、
マクロで使うから、
'Const 画像頭文字 = "交換画像" の図形や画像、シェイプの
名前を変更しといてね。

と
簡単に言うけど、
意外と重労働。
※対話式AI「Copilot」副操縦士のコパイロット様がパワーポイントに導入されたら、
　こんなマクロや作業は用済みなんだけど、
　あと数週間、数か月？待てないので使ってみてね。

コードの解説は前回の動画:
マクロ パワポ 選択されたオブジェクト・シェイプに名前を付ける IDを使用したり連番を振る PowerPointVBA Shape Name
https://www.youtube.com/watch?v=YcbjdXfk94A
↑の解説とコメント欄のコードを見てください。

'選択されたシェイプに名前を付ける
'入力された名前 + 連番にする
'※使い方で、重複した名前が付けられるので、注意すること・・
Sub pp選択Shapeに名前プラス連番を付ける0601()

    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ページをセット
    
    Dim strNewName As String   '新しくつける名前の頭文字
    strNewName = InputBox("名前の頭 XXXは？", "名前入力", "名前XXX")
    If strNewName = "" Then
        MsgBox "処理を中止しました、キャンセルします"
        Exit Sub
    End If
    
    Debug.Print "Id", "Name", "Type"

    Dim n As Long
    For n = 1 To ActiveWindow.Selection.ShapeRange.Count '選択された数までループ
        Set objShape = ActiveWindow.Selection.ShapeRange(n) '←この選択されたシェイプの名前を変更
        
        Debug.Print objShape.Id, objShape.Name, objShape.Type

        objShape.Name = strNewName & n  '連番にする
        '頭0を付けたい時は = strNewName & Format(n, "000") などアレンジしてね
        DoEvents
    Next

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

End Sub

6.終わりの挨拶

こんな感じのテストコードですが、
アレンジして、
使ってみてください。

※対話式AI「Copilot」副操縦士のコパイロット様がパワーポイントに導入されたら、
　こんなマクロや作業は用済みなんだけど、
　あと数週間、数か月？待てないので使ってみてね。