三流君 ken3のmemo置き場

三流プログラマーのメモ書きです。主にVBAやWindowsの話題が多いです

挨拶・自己紹介:
失敗続きのAB型の変わり者 :三流プログラマー Ken3です
フリーのエンジニア・個人事業主です・・と書くと聞こえはイイが(それとなくカッコよく聞こえるが)、 現在は小さな案件の受注請負 と 短期派遣 で 日々つつましく?ほそぼそと暮らしてます。

よく検索されるキーワード: [質問回答XXXXさんへ] [CreateObject] [VBA] [JRA競馬オッズ]

パワポ スライド内 画像表示位置を入れ替え 単純に.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」副操縦士のコパイロット様がパワーポイントに導入されたら、
 こんなマクロや作業は用済みなんだけど、
 あと数週間、数か月?待てないので使ってみてね。

Ken3 ホームページ 目次

分類:HPを大きく分けると4つの柱(分類)です。

  1. [VBA・マクロ プログラミング]の解説
    当店の人気はVBA系のCreateObject("XXXXXX.application")で他のアプリケーションを操作するサンプルが人気です
  2. [プログラマーの愚痴]では、あまり見せたくない三流プログラマーの内面かな。
    三流君を踏み台にする
  3. [古いクラシック ASP(Active Server Pages)]の解説。
  4. [元コンビニ店長時代の話]が弟に巻き込まれ、失敗した脱サラ、畑違い?の仕事で失敗。
主に上記4つの分類でHP作成やメルマガの発行を行ってます。
※更新頻度が落ちていて情報の鮮度が悪いです。



本当に三流なんです(笑):たまにスゴイですねなんて言われることもありますが、
真実は→ [三流君の真実は...] ←を初めに見てくださるとわかると思います。
(からくりは、成功例↑しか載せてなくて ヒドイ失敗例はお蔵入り迷宮入りが多かったりします)