三流君 ken3のmemo置き場

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

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

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

PowerPoint テキストや図形の位置LeftとTopをExcelシートへ シートの座標修正後に再度パワポに戻し位置を移動させる手順を解説

単純にシェイプの Shape.Leftと.Topを取得してシートに書き出す。
次に、逆のシートの値をパワポのShape.Leftと.Topにセットして、
移動っぽく処理しただけです。
大量テキストや図形の移動処理のヒントとなれば幸いです。
youtu.be
https://youtu.be/zYczLG7wF9E
目次
00:00 やりたいこと
01:25 1.テキストや図形の位置LeftとTopを取得
04:01 2.シートの値をShape.Leftと.Topにセット
09:43 3.コードの組み込み方法
10:12 3.1 取得コードを組み込む テストする
12:08 3.2 移動のコードを組み込む テストする
14:00 3.3 基準となるタイトル位置を決めます
14:44 3.4 Sheet1でデータを取得します
15:01 3.5 フィルターをかけ Title1を絞り込みます
15:34 3.6 タイトルのデータをコピーします
15:44 3.7 隣の移動用シートに貼り付けます
15:52 3.8 基準となる データをコピーします 3.9 マクロを走らせます
18:18 タイトル以外の違う項目を移動テストする
20:06 3.10 タイトルに規則性が無かったら?どうする?
24:05 4.蛇足ついでにテキスト変更してみた・・おまけです

#ms365 #PowerPointVBA #マクロ #PowerPoint #パワポ #パワーポイント
#ExcelVBA #エクセル
#テキスト #図形 #位置を移動
#作成方法 #初心者 #プレゼン
#Left #Top

1.テキストや図形の位置LeftとTopを取得 01:25 ~

図001 PowerPointからテキスト・図形の位置をExcelシートへ

過去に作成した、似ている処理を修正してみます。

Excel VBAPowerPointのタイトルテキストを取得したい Shapes から テキストを取り出す
ken3memo.hatenablog.com
↑ここのソースコードに、
位置.Leftと.Topを取得してC列・D列にセットする
下記コードを追加で書いただけでした。

'起動済みの既存 パワーポイント
'スライド .Shapes から 位置 Left,Top と テキストを取り出す
'アクティブシートに名前と位置,テキストをセット ※勝手に全クリアして書き込むので※※注意
Sub test20230225_01スライド内テキストの位置と中身を取得()

    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") = "名前 Shape.Name"
    Range("C1") = "左位置.Left"
    Range("D1") = "上位置.Top"
    Range("E1") = "テキスト objShape.TextFrame.TextRange.Text"

    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.Name  'オブジェクトの名前
         
            Cells(y, "C") = objShape.Left  '位置 左上の左 20230225追加
            Cells(y, "D") = objShape.Top   '位置 左上の縦
         
            'オブジェクトがテキストを持っているか?チェックしてからセット
            If objShape.HasTextFrame = msoTrue Then 'テキストフレームあり
                If objShape.TextFrame.HasText = msoTrue Then 'テキスト範囲あり
                    Cells(y, "E") = objShape.TextFrame.TextRange.Text 'E列へテキスト
                End If
            End If
            
            y = y + 1   'セットする行を次へ
            
        Next
    Next
    
    MsgBox "処理終了、確認してください"
    
End Sub

2.シートの値をShape.Leftと.Topにセット 04:01 ~
上でシートに値を取り込めたので、
今度は逆の シートの値(Left,Top)を 既存のパワポにセットしてみます

図002 Excelシートで修正・調整した位置をPowerPointのテキスト・図形にセットして移動する

まぁ、特に凝った処理はしていなくて

p = Cells(y, "A")          'A列からスライド番号(ページ番号)
strShpName = Cells(y, "B") 'B列から名前
'A列から↑pページ B列の名前を使う
Set objShape = ppApp.ActivePresentation.Slides(p).Shapes(strShpName)

で、単純に取得
あとは、値のセットで、これも単純にC列とD列の値をセットしただけでした

'やっと位置をセット、これで移動っぽくしてみた
objShape.Left = Cells(y, "C")   '位置 左上の左 20230225追加
objShape.Top = Cells(y, "D")    '位置 左上の縦

完成したソースコードが下記です。アレンジして使ってみてください。

'起動済みの既存 パワーポイント
'シートの値(Left,Top)を 既存のパワポにセットしてみます
'アクティブシートのA列のPage B列のシェイプに
'C列LeftとD列Topをセット
Sub test20230225_02シェイプの位置LeftとTopをセットする()

    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 strShpName As String  'シェイプの名前
    Dim objShape   As Object  'As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか
        
    y = 2  '1行目が見出しなので、二行目からデータをセットする
    While Len(Cells(y, "A")) <> 0 'A列の文字数が0以外の間ループ、A列がなくなるまで
        p = Cells(y, "A")          'A列からスライド番号(ページ番号)
        strShpName = Cells(y, "B") 'B列から名前
        Set objShape = Nothing  '初期化
        On Error Resume Next  '取得エラー時に次へ行く
        'pページのスライド内のシェイプを取得 A列のページ と B列の名前を使う
        Set objShape = ppApp.ActivePresentation.Slides(p).Shapes(strShpName)
        On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
        
        If objShape Is Nothing Then  '名前のエラーチェック
            MsgBox p & "ページの名称" & strShpName & "が見つかりません、確認してください"
            Exit Sub
        End If
        
        'やっと位置をセット、これで移動っぽくしてみた
        objShape.Left = Cells(y, "C")   '位置 左上の左 20230225追加
        objShape.Top = Cells(y, "D")    '位置 左上の縦

        y = y + 1   '次のデータへ
            
    Wend
    
    MsgBox "処理終了、確認してください"
    
End Sub

3.コードの組み込み方法 09:43 ~

detail.chiebukuro.yahoo.co.jp

上記、知恵袋の質問 タイトル位置を移動させたいを実演してみる

おまけ、って言うか、本題?
知恵袋の質問 タイトル位置を移動させたいを実演してみる

目的のパワポを開きます(※コピーしてから使ってくださいね)
新規、Excelブックを開きます

3.1 取得コードを組み込む テストする 10:12 ~

'下記のコードをコピーします
    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") = "名前 Shape.Name"
    Range("C1") = "左位置.Left"
    Range("D1") = "上位置.Top"
    Range("E1") = "テキスト objShape.TextFrame.TextRange.Text"

    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.Name  'オブジェクトの名前
         
            Cells(y, "C") = objShape.Left  '位置 左上の左 20230225追加
            Cells(y, "D") = objShape.Top   '位置 左上の縦
         
            'オブジェクトがテキストを持っているか?チェックしてからセット
            If objShape.HasTextFrame = msoTrue Then 'テキストフレームあり
                If objShape.TextFrame.HasText = msoTrue Then 'テキスト範囲あり
                    Cells(y, "E") = objShape.TextFrame.TextRange.Text 'E列へテキスト
                End If
            End If
            
            y = y + 1   'セットする行を次へ
            
        Next
    Next
    
    MsgBox "処理終了、確認してください"
'↑ここまで

3.1.1 sheet1に図形を挿入します。
3.1.2 右クリックを押しマクロの登録を選択します
3.1.3 新規作成をします

コードを貼り付けます

3.1.4 Excelの図形を押して確認します


3.2 移動のコードを組み込む テストする 12:08 ~

シートを追加します
※隣に新規シートを追加します。

テストなので、1~2ページのタイトルをコピーします

'下記のコードをコピーします
    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 strShpName As String  'シェイプの名前
    Dim objShape   As Object  'As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか
        
    y = 2  '1行目が見出しなので、二行目からデータをセットする
    While Len(Cells(y, "A")) <> 0 'A列の文字数が0以外の間ループ、A列がなくなるまで
        p = Cells(y, "A")          'A列からスライド番号(ページ番号)
        strShpName = Cells(y, "B") 'B列から名前
        Set objShape = Nothing  '初期化
        On Error Resume Next  '取得エラー時に次へ行く
        'pページのスライド内のシェイプを取得 A列のページ と B列の名前を使う
        Set objShape = ppApp.ActivePresentation.Slides(p).Shapes(strShpName)
        On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
        
        If objShape Is Nothing Then  '名前のエラーチェック
            MsgBox p & "ページの名称" & strShpName & "が見つかりません、確認してください"
            Exit Sub
        End If
        
        'やっと位置をセット、これで移動っぽくしてみた
        objShape.Left = Cells(y, "C")   '位置 左上の左 20230225追加
        objShape.Top = Cells(y, "D")    '位置 左上の縦

        y = y + 1   '次のデータへ
            
    Wend
    
    MsgBox "処理終了、確認してください"
'ここまで

3.2.1 sheet2(追加した隣のシート)に図形を挿入します。
3.2.2 右クリックを押しマクロの登録を選択します
3.2.3 新規作成をします

コードを貼り付けます

3.2.4 Excelの図形を押して確認します


3.3 基準となるタイトル位置を決めます

3.4 Sheet1でデータを取得します

3.5 フィルターをかけ Title1を絞り込みます

3.6 タイトルのデータをコピーします

3.7 隣の移動用シートに貼り付けます

3.8 基準となる データをコピーします

3.9 マクロを走らせます


3.10 なんて、感じでうまくいけばいいんだけど、 20:06 ~
そんなに世の中、実データは甘くなかったり・・・

>3.5 フィルターをかけ Title1を絞り込みます

なんて、書いてたけど、
タイトルって?そのまま使う人と、
ア.白紙から作る人がいたり
イ.間違ってタイトルを消してしまい、テキストボックスで同じ位置に追加したり・・・

Title1って、名前じゃなかったりして・・・

そんな時は、フィルターの絞り込みで、LeftとTopを範囲指定して、なんとかするのかなぁ・・・

以上、アレンジして、使ってみてください。

大量スライドの図形やテキストの移動時
作業軽減となればうれしいです。

終わりにすればいいのに、蛇足で思い付きのテキスト変更をやってみた・・・
4.蛇足ついでにテキスト変更してみた・・おまけです 24:05 ~

objShape.TextFrame.TextRange.Text = Cells(y, "E") 

↑動画内では、E列を逆に TextFrame.TextRange へ戻して
それっぽくうまくいったけど、
テキストを持たないオブジェクトにセットすると、
エラーになると思うので、少し細工が必要かも。
まぁ、おまけの処理、思い付きなので、
チェックなどを入れて、アレンジしてください。

※下記、冒頭と同じ動画です。本文が長くなったので、下にも貼りました
マクロ パワポ テキストや図形の位置LeftとTopを取得 大量のテキスト・図形を移動 PowerPoint VBA作成方法を初心者がプレゼンしてみた - YouTube
目次
00:00 やりたいこと
01:25 1.テキストや図形の位置LeftとTopを取得
04:01 2.シートの値をShape.Leftと.Topにセット
09:43 3.コードの組み込み方法
10:12 3.1 取得コードを組み込む テストする
12:08 3.2 移動のコードを組み込む テストする
14:00 3.3 基準となるタイトル位置を決めます
14:44 3.4 Sheet1でデータを取得します
15:01 3.5 フィルターをかけ Title1を絞り込みます
15:34 3.6 タイトルのデータをコピーします
15:44 3.7 隣の移動用シートに貼り付けます
15:52 3.8 基準となる データをコピーします 3.9 マクロを走らせます
18:18 タイトル以外の違う項目を移動テストする
20:06 3.10 タイトルに規則性が無かったら?どうする?
24:05 4.蛇足ついでにテキスト変更してみた・・おまけです

Ken3 ホームページ 目次

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

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



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