パワポ書式をコピー後、別ページの同じ位置のシェイプに適応したい Shape PickUpメソッド Applyメソッド PowerPointVBA デバッグ

パワーポイントのシェイプの書式をコピーしたかったので

Shape.PickUp メソッド
と
Shape.Apply メソッド
を使ってみました。
youtu.be
https://youtu.be/YHv3oVOS6BQ
目次
00:00 動作・実行結果テスト実演
01:34 1.単体テスト PickUp Apply
06:30 2.選択シェイプの判断 Selection.ShapeRange を使用
09:52 3.結合テスト他のページ、同じ位置のシェイプに書式を適応させる
14:45 他のpptxファイルで再テスト

#PowerPointVBA #コピペ #デバッグ

Shape.PickUp メソッド (PowerPoint)
https://learn.microsoft.com/ja-jp/office/vba/api/powerpoint.shape.pickup
図形の書式をコピーします。コピーした書式を別の図形に適用するには、 Apply メソッドを使用します。

Shape.Apply メソッド (PowerPoint)
https://learn.microsoft.com/ja-jp/office/vba/api/powerpoint.shape.apply
PickUp メソッドを使用してコピーされて、指定した図形の書式設定に適用されます。

知恵袋の質問、
detail.chiebukuro.yahoo.co.jp

＞Power Point VBA
＞パワーポイントの複数のスライドにて
＞指定の位置にあるテキストのみの書式を一括変更する方法はありますでしょうか？
＞書体、サイズ、太さを一括で変更したいです。

にチャレンジ、、、

1.単体テスト PickUp Apply 01:34 ～

テキストの中身は変更しないで、書式だけコピーする

テストで、
入力:Slides(1).Shapes("テキストボックス 3")を.PickUp
を
出力:名前固定でSlides2,3,4のShapes("テキストボックス 1") に .Apply
してみた。

Sub test0608書式コピーテスト001単体テスト()

    Dim ppShpMOTO As PowerPoint.Shape  'なんでも元、基準が必要だよね
    
    'テストコードなので、Slides(1)ページ目の"テキスト ボックス 3"を使用する
    Set ppShpMOTO = ActivePresentation.Slides(1).Shapes("テキスト ボックス 3")
    '↑スペースが含まれている名前が気になるけど、テストだからイッカ
    '自分でテスト、走らせるときに、注意してね
    
    '脱線したけど、単純に、.PickUp で 書式コピー
    ppShpMOTO.PickUp
    'ShapeからPickUp動作 ↑ピックアップ、選び取る？イメージだけど、書式のコピー

    'あとは、貼り付けるだけ Apply アプライ？英単語で調べると申し込み？アプラスとアコムは金貸しです。
    'スライドページ、2,3,4 の "テキスト ボックス 1"に
    '.Apply を指定して、適用(貼り付ける・・・)
    ActivePresentation.Slides(2).Shapes("テキスト ボックス 1").Apply
    ActivePresentation.Slides(3).Shapes("テキスト ボックス 1").Apply
    ActivePresentation.Slides(4).Shapes("テキスト ボックス 1").Apply

End Sub

2.選択シェイプの判断 Selection.ShapeRange を使用 06:30 ～

ActiveWindow.Selection.ShapeRange(1)
が
選択されたシェイプなので、これを利用する。

テストで、
入力:選択されたシェイプを.PickUp
を
出力:名前固定でShapes("テキストボックス 2") に .Apply
してみた。

'あとは、応用で、選択されたShapeの書式をコピーする
Sub test0608書式コピーテスト002選択されたShapeの書式()

    If ActiveWindow.Selection.Type <> ppSelectionShapes Then  '種類の判断
        MsgBox "Shape図形やテキストボックスを選択してね", vbExclamation
        Exit Sub
    End If
    
    Dim ppShpMOTO As PowerPoint.Shape  'なんでも元、基準が必要だよね
    Set ppShpMOTO = ActiveWindow.Selection.ShapeRange(1)
    '↑選択された１件目のシェイプオブジェクトを代入
    
    '単純に、.PickUp で 書式コピー、ふと↑で、ShapeRange(1).PickUp？で良くない？と思ったり
    ppShpMOTO.PickUp
    'ShapeからPickUp動作 ↑ピックアップ、選び取る？イメージだけど、書式のコピー

    'あとは、貼り付けるだけ Apply アプライ？英単語で調べると申し込み？
    'スライドページ、2,3,4 の "テキスト ボックス 2"に
    '.Apply を指定して、適用(貼り付ける・・・)
    ActivePresentation.Slides(2).Shapes("テキスト ボックス 2").Apply
    ActivePresentation.Slides(3).Shapes("テキスト ボックス 2").Apply
    ActivePresentation.Slides(4).Shapes("テキスト ボックス 2").Apply

    MsgBox "終了、結果を確認してください"

End Sub

3.結合テスト他のページ、同じ位置のシェイプに書式を適応させる 09:52 ～

テストで、
入力:選択されたシェイプを.PickUp
を
出力:.Leftと.Topが同じShapeに.Apply
してみた。

'同じ位置のシェイプの書式を合わせたい・・・
'選択されたシェイプの書式をコピーする
'各ページの 左上の座標 .Top , .Left が同じシェイプに貼り付ける
Sub test0608書式コピーテスト003同じ位置のシェイプ書式を合わせる()

    If ActiveWindow.Selection.Type <> ppSelectionShapes Then  '種類の判断
        MsgBox "Shape図形やテキストボックスを選択してね", vbExclamation
        Exit Sub
    End If
    
    Dim ppShpMOTO As PowerPoint.Shape  'なんでも元、基準が必要だよね
    Set ppShpMOTO = ActiveWindow.Selection.ShapeRange(1)
    '↑選択された１件目のシェイプオブジェクトを代入
    
    '単純に、.PickUp で 書式コピー、ふと↑で、ShapeRange(1).PickUp？で良くない？と思ったり
    ppShpMOTO.PickUp
    'ShapeからPickUp動作 ↑ピックアップ、選び取る？イメージだけど、書式のコピー

    'あとは、貼り付けるだけ Apply アプライ？英単語で調べると申し込み？
    'スライドの頭からループで回す
    Dim ppSlide As PowerPoint.Slide  'スライドのオブジェクト
    Dim ppShp   As PowerPoint.Shape  'シェイプのオブジェクト
    
    For Each ppSlide In ActivePresentation.Slides  '全スライドのループ
        For Each ppShp In ppSlide.Shapes  'スライド内の全シェイプのループ
            '左上の位置が同じなら処理する
            If ppShp.Top = ppShpMOTO.Top And ppShp.Left = ppShpMOTO.Left Then
                ppShp.Apply  '書式を貼り付ける
            End If
        Next
    Next
    '↑全てのシェイプをループで漁るので、ppShpMOTOの同じシェイプに貼り付けるけどOKかな。
    
    MsgBox "終了、結果を確認してください"

End Sub

4.終わりの挨拶

時間泥棒になってしまいますが、
動画の頭から
https://www.youtube.com/watch?v=YHv3oVOS6BQ
見ていただけると、嬉しいです。
目次
00:00 動作・実行結果テスト実演
01:34 1.単体テスト PickUp Apply
06:30 2.選択シェイプの判断 Selection.ShapeRange を使用
09:52 3.結合テスト他のページ、同じ位置のシェイプに書式を適応させる
14:45 他のpptxファイルで再テスト

Shapeの
PickUpメソッド
と
Applyメソッド
で、
書式のコピペができるので、
アレンジして使ってみてください。

解決のヒントとなれば幸いです。

イラスト男性髪の色はオレンジ PCを操作中大量の文字を修正作業中