PowerPointの情報位置とサイズを取得 ExcelからPowerPointのシェイプ位置とサイズを書き換える

01:04:36 サンプルのプレゼンリモートワークの服装を紹介
サンプルのプレゼン画像のサイズと位置を変更するマクロ
https://www.youtube.com/watch?v=o0PVL1v27Ts&t=3876
を紹介する

Option Explicit

Sub 矢印左1_Click()

End Sub

'起動済みの既存 パワーポイント からシェイプの情報を取得する
Sub test20240302_03ppのシェイプの名前と位置サイズを取得()

    Dim ppApp As Object 'As PowerPoint.Application
    
    Set ppApp = Nothing 'エラーチェックのため初期化
    On Error Resume Next  '取得エラー時に次へ行く
    Set ppApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意

    If ppApp Is Nothing Then
        MsgBox "パワポを取得できません。プレゼンスライドを開いてから、再テストしてね"
        Exit Sub
    End If

    Cells.ClearContents     'アクティブシートを※勝手に全クリアして書き込むので※※注意
    Range("A1").Select
    '見出しを書き込む
    Range("A1") = "Page番号"
    Range("B1") = "ID"
    Range("C1") = "名前 Shape.Name"
    Range("D1") = "種類 .Type"  '※
    Range("E1") = "左位置.Left"     '位置等で絞り込む？
    Range("F1") = "上位置.Top"
    
    '幅と高さ 24/03/02
    Range("G1") = "幅 .Width"     '位置等で絞り込む？
    Range("H1") = "高さ .Height"
    
    
    Range("I1") = "テキスト 先頭から10文字"  'テキストがあれば判断時便利かな？

    Dim p As Integer, y As Integer   'pページ、y行
    Dim objShape As Object  'As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか
        
    y = 2  '取得したテキストデータを二行目から書きたいので
    For p = 1 To ppApp.ActivePresentation.Slides.Count  'スライド数ループ pページ
        'pページのスライド内のシェイプを探る
        For Each objShape In ppApp.ActivePresentation.Slides(p).Shapes
            Cells(y, "A") = p   'スライド番号(ページ番号)
            Cells(y, "B") = objShape.ID    'IDで今回、区別したいので※24/03/02追加
            Cells(y, "C") = objShape.Name  'オブジェクトの名前
            Cells(y, "D") = objShape.Type  '※種類
         
            Cells(y, "E") = objShape.Left  '位置 左上の左 判断材料
            Cells(y, "F") = objShape.Top   '位置 左上の縦
         
            Cells(y, "G") = objShape.Width '
            Cells(y, "H") = objShape.Height
            
            'オブジェクトがテキストを持っているか？チェックしてからセット
            If objShape.HasTextFrame = msoTrue Then 'テキストフレームあり
                If objShape.TextFrame.HasText = msoTrue Then 'テキスト範囲あり
                    Cells(y, "I") = Left(objShape.TextFrame.TextRange.Text, 10)
                    'G列へテキストを10文字だけ書き込む↑,99文字など好みの文字で
                End If
            End If
            
            y = y + 1   'セットする行を次へ
            
        Next
    Next
    
    MsgBox "処理終了、名前を確認・修正してください"

End Sub

'Excel D列に値があったら、起動済みのパワーポイントへD列の名前をセットする
'A列:Page,B列:Idを使用して、シェイプを探し、
'NameプロパティにD列の値をセットする
Sub test20240302_04Excelからppシェイプの位置とサイズを変更する()

    Dim ppApp As Object 'As PowerPoint.Application
    
    Set ppApp = Nothing 'エラーチェックのため初期化
    On Error Resume Next  '取得エラー時に次へ行く
    Set ppApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意

    If ppApp Is Nothing Then
        MsgBox "パワポを取得できません。プレゼンスライドを開いてから、再テストしてね"
        Exit Sub
    End If

    Dim p As Integer, y As Integer   'pページ、y行
    Dim ShpWORK As Object   'As PowerPoint.Shape ループでIDを探すときに使う
    Dim objShape As Object  'As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか
        
    '二行目からB列IDがなくなるまでループする
    For y = 2 To 9999  '9999までと言いつつ↓で終了チェック、おいおい・・・
        If Trim("" & Cells(y, "B")) = "" Then Exit For  'B列に値が無かったら、ループを抜ける
        
        Set objShape = Nothing  'セット先のシェイプを初期化
        
        'pページのスライド内のシェイプをIDで探して値をセットする
        p = Cells(y, "A")   'スライド番号(ページ番号)
        For Each ShpWORK In ppApp.ActivePresentation.Slides(p).Shapes 'ページ内の全てをあさる
            'IDが一致するか、チェックする
            If ShpWORK.ID = Cells(y, "B") Then  'B列のIDと比較
                Set objShape = ShpWORK  '見つけたので、オブジェクトをセットする
                Exit For   '探すループを抜ける
            End If
        Next   'IDを探す↑ループ

        'ID有無の判断
        If objShape Is Nothing Then  '見つからないとき
            MsgBox p & "ページのID=" & Cells(y, "B") & "が見つかりません"
        Else
            '位置とサイズ

            objShape.Left = Cells(y, "E")   '位置 左上の左 判断材料
            objShape.Top = Cells(y, "F")   '位置 左上の縦
         
            objShape.Width = Cells(y, "G")   'サイズ
            objShape.Height = Cells(y, "H")
        
        End If
        
    Next y   '行の↑ループ

    MsgBox "処理終了、セットされた名前を確認してください"

End Sub

一括処理の参考となれば、幸いです。

#ExcelVBA #PowerPointVBA #マクロ #シェイプ #Shape #デバッグ

似た処理の過去動画の紹介:
Excelを使いパワポの図形やテキストを大量に移動したい位置LeftとTopを取得値を変更後セットして移動する ExcelからPowerPoint操作 VBA
https://www.youtube.com/watch?v=zYczLG7wF9E
や
マクロパワポのテキストをExcelへ書き出す起動済みの既存スライド Shapes からテキスト取得デバッグ方法マクロの作り方・使い方
https://www.youtube.com/watch?v=FZovWjt0xtQ
を
参考にして、ソースを作成してみました。