実験動画表示アウトラインでタイトルが表示されるのでタイトルを指定テキストにしたいパワポマクロ

パワポで表示アウトラインでタイトル部分がリンク表示されるので、変更したい
何言ってんだ？

キッカケ下記知恵袋の質問でアウトライン表示が気になったので触ってみた。
detail.chiebukuro.yahoo.co.jp

パワーポイントにタイトルを別テキストに設定する操作メニューが無かったので、
マクロでテキストボックスとタイトルを交換するイメージでやってみました。

www.youtube.com
https://www.youtube.com/live/E39o37zw-8c

00:00 1.表示アウトライン
表示アウトラインでは、
タイトル(とプレースホルダ)が表示されます。
左側の表示だけじゃなく、入力もできます

06:16 2.左側の表示(タイトル)を変えたい
訳ありで、左側の表示を変えたいけど、
既にタイトルとして、スライドが作成されています。
そんな時、下記のマクロを使ってみてください。

操作手順
08:49 マクロのコピーと貼り付け
10:10 タイトルにしたい、テキストボックスを選択して、マクロを実行。

13:49 マクロの中身を説明する:

1.タイトルをコピー、複製を作り、位置をタイトルと同じにする
2.交換元テキストに対して
2.1 タイトルを移動
2.2 文字列を代入
2.3 書式を代入
2.4 交換元テキストボックスを消し、交換されたっぽく見せる
※既存のタイトルオブジェクトに代入して、指定したようにみせたただけ・・・

Sub タイトルの交換処理もどき231014()

    '選択をチェック
    If ActiveWindow.Selection.Type <> ppSelectionShapes Then  '種類の判断
        MsgBox "テキストボックスを選択してね", vbExclamation
        Exit Sub
    End If
    
    '現在スライドを保存
    Dim nPAGE As Integer
    nPAGE = ActiveWindow.Selection.SlideRange.SlideIndex '現在選択しているページ
    
    Dim objSlide As PowerPoint.Slide  'スライド
    Set objSlide = ActivePresentation.Slides(nPAGE) '↑現在のページを変数に

    '選択されたシェイプをまず変数に保存する※あとで入れ替えるので
    Dim 交換元Shape As PowerPoint.Shape  'シェイプ
    Set 交換元Shape = ActiveWindow.Selection.ShapeRange(1)
    
    'タイトルを細工したい※複製作成後、テキストボックスと入れ替えたい
    Dim objTITLE As PowerPoint.Shape  'タイトル シェイプ
    Set objTITLE = objSlide.Shapes.Title  'タイトルの代入
    objTITLE.Copy  'タイトルを複製したいのでコピーする
        
    Dim objShpRange As PowerPoint.ShapeRange
    Set objShpRange = objSlide.Shapes.Paste  '↑コピペ結果がShapeRangeで返る

    Dim objShp As PowerPoint.Shape  'コピー後のシェイプ
    Set objShp = objShpRange(1)     '一番目を代入
    objShp.Name = "コピー後タイトル" & objShp.Id  '新しい名前を付ける
    objShp.Left = objTITLE.Left  '位置をタイトルと同じ位置にする
    objShp.Top = objTITLE.Top

    '元テキストに対して 1タイトルを移動後、2文字列を代入、3書式を代入、4元テキストを消す
    With 交換元Shape
        '1タイトルを選択テキストの位置へ移動
        objTITLE.Left = .Left
        objTITLE.Top = .Top
        '2文字列を代入 タイトルの書き換え
        objTITLE.TextFrame.TextRange.Text = .TextFrame.TextRange.Text
        '3書式を代入
        .PickUp  '.PickUp で 書式コピー
        objTITLE.Apply  '書式貼付け
        '4元テキストのシェイプを消す
        .Delete   'シェイプの削除※これで、タイトルと交換した感じになる
    End With

    MsgBox "処理終了、アウトラインでタイトルを確認してください"

End Sub