パワポ Shapes AddTextboxでテキストボックスを新規追加応用で作成Excel選択範囲をPowerPointへ１つ１つセット

PowerPointのマクロでテキストボックスを新規作成する
Shapes.AddTextboxの単体テストです。
www.youtube.com
マクロの実行結果を先に紹介する
1.パワポのマクロで新規スライドにテキストボックスを追加する
2.パワポのマクロで起動済みExcelの選択範囲からテキストを抜き出し、テキストボックスを作成する
3.VBSでExcelの選択範囲を使いPowerPointでテキストボックスを作成する

https://www.youtube.com/live/1FNXLH_re6k
目次
00:00 あいさつマクロの実行結果を先に紹介する
00:49 1.パワポのマクロで新規スライドにテキストボックスを追加する
02:36 2.パワポのマクロで起動済みExcelの選択範囲からテキストを抜き出し、テキストボックスを作成する
07:33 3.VBSでExcelの選択範囲を使いPowerPointでテキストボックスを作成する

12:56 解説 1.PowerPoint VBA テキストボックスの追加単体テスト
19:33 修正 1.1 現在スライドに追加する

26:35 解説 2.PowerPointから起動済みExcelの選択範囲を１つ１つ取り出しセットする
31:26 修正現在スライドに追記対応にすると
36:35 修正 2.1 .Font.Size = ExcelRange.Font.Size セルのフォントサイズを使用する

41:54 3.VBSの設置とテストこんな感じで使って下さい
45:41 ※文字コードはANSIで必ず保存する
47:21 vbsで設置したコードの説明
52:24 Font SizeをExcelに合わせる修正
54:59 3.1 .Text と .Valueとの違いを実演する
01:01:28 終わりの挨拶 4.アレンジして、使ってみてください。

簡単な解説を始めたいと思います。

1.PowerPoint VBA テキストボックスの追加単体テスト
 https://www.youtube.com/watch?v=1FNXLH_re6k&t=776s
ポイントは、特になく、
Set ppShape = ppSld.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 100, 300, 50)

shp = Shapes.AddTextbox(方向, Left:左上 , Top:上位置, Width:幅, Height:高さ)
で、
追加したShapeテキストボックスが返るので、
With Shp.TextFrame.TextRange '↑で追加したTextFrameのテキスト範囲に対して
.Text = "テストの文字列"
.Font.Size = 24 'フォントサイズ24 でテストほかもイロイロあるけど
End With
みたいに、プロパティをセットしただけでした。

'スライドを追加後
'テキストボックスを作成するテスト
Sub AddTextboxの単体テスト240304_固定文字をセット()

    '新規のスライド追加をテストする
    Dim p As Integer
    Dim ppSld As PowerPoint.Slide

    p = ActivePresentation.Slides.Count + 1 '追加するページ=スライド枚数+1※最後に追加
    Debug.Print p & "スライドページに追加してみる"

    'ppLayoutBlank:12 ppLayoutTitle:1 など、
    Set ppSld = ActivePresentation.Slides.Add(p, ppLayoutBlank)
    ppSld.Select  '↑で追加したスライドオブジェクトが返るので選択してみた

    'テキストの追加
    Dim ppShape As PowerPoint.Shape

    'テキストの方向を指定します｡
    'msoTextOrientationHorizontal : 1   横方向, Left:左上 , Top:上位置, Width:幅, Height:高さ
    Set ppShape = ppSld.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 100, 300, 50)
    '↑ 左上位置を(0,100)、サイズを300*50に適当にしてますが、オーバーした時？
    Debug.Print "テキスト追加前.Height:" & ppShape.Height
    
    With ppShape.TextFrame.TextRange  '↑で追加したTextFrameのテキスト範囲に対して
        .Text = "テストの文字列"
        .Font.Size = 48    'フォントサイズ48 でテスト ほかもイロイロあるけど
    End With
 
    Debug.Print "テキスト追加後.Height:" & ppShape.Height

End Sub

1.1 現在スライドに追加する

? activewindow.Selection.SlideRange.SlideIndex
5

新規追加をコメントにして
    'ppLayoutBlank:12 ppLayoutTitle:1 など、
    'Set ppSld = ActivePresentation.Slides.Add(p, ppLayoutBlank)
    'ppSld.Select  '↑で追加したスライドオブジェクトが返るので選択してみた

選択スライドを代入
    p = ActiveWindow.Selection.SlideRange.SlideIndex 'ページ
    Set ppSld = ActivePresentation.Slides(p)

2.PowerPointから起動済みExcelの選択範囲を１つ１つ取り出しセットする

応用編で、
PowerPointから起動済みのExcelをつかまえて、
選択範囲を取り込んでみました。
https://www.youtube.com/watch?v=1FNXLH_re6k&t=1595s

Set ExcelApp = GetObject(, "Excel.Application")
で、Excelをつかまえて、
選択範囲のセルを
For Each ExcelRange In ExcelApp.Selection 'Excelの選択範囲を１つ１つ取り出す
で、取得して
あとは、パワーポイントにテキストボックスを追加後、
値をセットしただけです。

単純なので、ソースコードを見て、アレンジしてください。

'よく聞く質問、Excelの選択範囲を取り込みたい
'そのままコピーすると、１つにまとまってしまうから、
'１つ１つ取得したい
Sub Excelの選択テキストを取得_AddTextboxの応用テスト240304()

    '起動済みのExcelを捕まえる
    Dim ExcelApp As Object    '参照設定したくないので、Object型で取得する
    
    Set ExcelApp = Nothing
    On Error Resume Next  'エラーが発生しても強引に次の命令に行け
    Set ExcelApp = GetObject(, "Excel.Application")
    On Error GoTo 0  '忘れないで戻すぞ

    If ExcelApp Is Nothing Then
        MsgBox "起動済みのExcelが見つかりません"
        Exit Sub
    End If

    '新規のスライド追加をテストする
    Dim p As Integer
    Dim ppSld As PowerPoint.Slide

    p = ActivePresentation.Slides.Count + 1 '追加するページ=スライド枚数+1※最後に追加
    Debug.Print p & "スライドページに追加してみる"

    'ppLayoutBlank:12 ppLayoutTitle:1 など、
    Set ppSld = ActivePresentation.Slides.Add(p, ppLayoutBlank)
    ppSld.Select  '↑で追加したスライドオブジェクトが返るので選択してみた

    'テキストの追加
    Dim ppShape As PowerPoint.Shape
    Dim set_X As Double  'セット位置
    Dim set_Y As Double
    Dim set_FontSize As Double

    Dim ExcelRange As Object  'Excelは長い、exRange？かxlRange？r一文字でもいいか？
    
    set_X = 0      '初期位置をセット
    set_Y = 150
    set_FontSize = 48

    For Each ExcelRange In ExcelApp.Selection  'Excelの選択範囲を１つ１つ取り出す
        'ppセットするテキストの方向を指定します｡
        'msoTextOrientationHorizontal : 1   横方向, Left:左上 , Top:上位置, Width:幅, Height:高さ
        Set ppShape = ppSld.Shapes.AddTextbox(msoTextOrientationHorizontal, set_X, set_Y, 500, 50)
        '↑ 左上セット位置をサイズは500*50と長めでテスト
        Debug.Print "テキスト追加前.Height:" & ppShape.Height
        
        With ppShape.TextFrame.TextRange  '↑で追加したTextFrameのテキスト範囲に対して
            .Text = ExcelRange.Text   'Excelセルのテキストをセットする
            .Font.Size = set_FontSize 'フォントサイズ あっ、ここもセルのフォント？がいいかも？
        End With
         
        '文字数が多いと、高さが変わるので、高さ+20で次の位置を計算する
        Debug.Print "テキスト追加後.Height:" & ppShape.Height
        set_Y = set_Y + ppShape.Height + 20  '追加したテキストボックス高さ+20にしてみた
    Next

End Sub

2.1 .Font.Size = set_FontSize 'フォントサイズあっ、ここもセルのフォント？がいいかも？

? range("b3").Font.Size
36
東京
range("b3").Font.Size = 96

.Font.Size = ExcelRange.Font.Size 'セルのフォント？がいいかも？

3.VBSの設置
https://www.youtube.com/watch?v=1FNXLH_re6k&t=2514s
使いたい時にサクっと使用可能にするために、
ツールっぽくデスクトップにVBSファイルを設置します。

視聴者の声:「えっ、廃止予定のVBSでやるの？アドインの設置を勉強しろよ・・・」

'----  XXXX.vbs で デスクトップなどに保存して使ってください
'文字コードに注意 ANSI にする

Call Main240304() '処理を呼ぶ

Sub Main240304()  'Excelの選択範囲からパワポのテキストボックスを作成する

    '起動済みのパワポを捕まえる
    Dim ppApp
    
    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

    '起動済みのExcelを捕まえる
    Dim ExcelApp  
    
    Set ExcelApp = Nothing
    On Error Resume Next  'エラーが発生しても強引に次の命令に行け
    Set ExcelApp = GetObject(, "Excel.Application")
    On Error GoTo 0  '忘れないで戻すぞ

    If ExcelApp Is Nothing Then
        MsgBox "起動済みのExcelが見つかりません"
        Exit Sub
    End If

    '新規のスライド追加をテストする
    Dim p
    Dim ppSld  'As PowerPoint.Slide

    p = ppApp.ActivePresentation.Slides.Count + 1 '追加するページ=スライド枚数+1※最後に追加
 
    'ppLayoutBlank:12 ppLayoutTitle:1 など、
    Set ppSld = ppApp.ActivePresentation.Slides.Add(p, 12)
    ppSld.Select  '↑で追加したスライドオブジェクトが返るので選択してみた

    'テキストの追加
    Dim ppShape  'As PowerPoint.Shape
    Dim set_X 'セット位置
    Dim set_Y 
    Dim set_FontSize

    Dim ExcelRange 'Excelは長い、exRange？かxlRange？r一文字でもいいか？
    
    set_X = 0      '初期位置をセット
    set_Y = 150
    set_FontSize = 48

    For Each ExcelRange In ExcelApp.Selection  'Excelの選択範囲を１つ１つ取り出す
        'ppセットするテキストの方向を指定します｡
        'msoTextOrientationHorizontal : 1   横方向, Left:左上 , Top:上位置, Width:幅, Height:高さ
        Set ppShape = ppSld.Shapes.AddTextbox(1, set_X, set_Y, 500, 50)
        '↑ 左上セット位置をサイズは500*50と長めでテスト
         
        With ppShape.TextFrame.TextRange  '↑で追加したTextFrameのテキスト範囲に対して
            .Text = ExcelRange.Text   'Excelセルのテキストをセットする
            .Font.Size = set_FontSize 'フォントサイズ あっ、ここもセルのフォント？がいいかも？
        End With
         
        '文字数が多いと、高さが変わるので、高さ+20で次の位置を計算する
        set_Y = set_Y + ppShape.Height + 20  '追加したテキストボックス高さ+20にしてみた
    Next


    MsgBox "処理終了、確認してください"

End Sub

'ここまで