Excel VBA で PowerPointのタイトルテキストを取得したい Shapes から テキストを取り出す

ExcelからPowerPointのテキストを取得したい

過去の記事:A列のデータをパワポへ
ken3memo.hatenablog.com

＞これの逆(パワポのスライドタイトルをExcelへ)ってできますか？

とコメントが来たので、パワポのテキストを取得してみたいと思います

下記、作成した解説動画です。ソースコードと合わせてみてください。
youtu.be
https://youtu.be/FZovWjt0xtQ
目次
00:00 質問内容
00:20 実行結果を見せながら説明する
01:37 1.Set ppApp = GetObject(, "PowerPoint.Application")
03:53 2.ActivePresentation.Slides.Count 'スライド数ループ pページ
04:53 3.For Each objShape In ppApp.ActivePresentation.Slides(p).Shapes
05:39 4.オブジェクトがテキストを持っているか？チェックしてからセット
11:36 5.おわりの挨拶
12:06 6.あっ、忘れてた、参照設定してね

実行結果を見せながら説明する
PowerPointのタイトルをExcelのA列にセット、取得したいと質問を受けたので、
ページ番号 シェイプの名前 テキスト
の3つをA,B,C列にセット、取得しました。

1.Set ppApp = GetObject(, "PowerPoint.Application")

GetObjectで起動しているパワポを取得する仕様にしました
ん？
二つ起動していたら？どうなるの？
For Each objShape In ppApp.ActivePresentation.Slides(p).Shapes
とアクティブな方を取ると思います。
心配なので、実行するときは、一つだけパワポファイルを起動してください。

2.ActivePresentation.Slides.Count 'スライド数ループ pページ

ActivePresentation.Slides.Count
でスライドの総ページがわかるので、
For p = 1 To ppApp.ActivePresentation.Slides.Count
で頭からループして
使うのは、
ppApp.ActivePresentation.Slides(p).Shapes
みたいに、pページ単位で処理します

3.For Each objShape In ppApp.ActivePresentation.Slides(p).Shapes

For Each objShape In ppApp.ActivePresentation.Slides(p).Shapes
で、一つ一つ、Shapeオブジェクトを取り出します。

Dim p As Integer, y As Integer   'pページ、y行
Dim objShape As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか
        
    y = 2  '取得したテキストデータを二行目から書きたいので
    For p = 1 To ppApp.ActivePresentation.Slides.Count  'スライド数ループ pページ
        'pページのスライド内のシェイプを探る
        For Each objShape In ppApp.ActivePresentation.Slides(p).Shapes

4.オブジェクトがテキストを持っているか？チェックしてからセット

あとは、シェイプオブジェクトがテキストを持っているか？
チェックして、セットしただけです

If objShape.HasTextFrame = msoTrue Then 'テキストフレームあり
      If objShape.TextFrame.HasText = msoTrue Then 'テキスト範囲あ
               Cells(y, "C") = objShape.TextFrame.TextRange.Text 'C列へテキスト
      End If
End If

ウォッチ式で探ったりすることも・・・
: HasTextFrame : msoTrue : MsoTriState : Module2.testスライド内テキストをDebugPrint
: HasText : msoTrue : MsoTriState : Module2.testスライド内テキストをDebugPrint
- : TextRange : : TextRange/TextRange : Module2.testスライド内テキストをDebugPrint
: Text : "オブジェクトがテキストを持っているか？チェックしてからセット" : String :

Module2.testスライド内テキストをDebugPrint

: HasTextFrame : msoFalse : MsoTriState : Module2.testスライド内テキストをDebugPrint

5.おわりの挨拶

こんな感じで、
パワーポイントのテキストを取得できました。
※図に入ったテキストまでとってくるのは蛇足かも・・・

ひとつでも、処理の参考となればうれしいです。

6.あっ、忘れてた、参照設定してね

Dim ppApp As PowerPoint.Application
や
Dim objShape As PowerPoint.Shape
を
使用しているので、
ツール 参照設定
PowerPointを選択してください。

ソース コード

Option Explicit

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

    Dim ppApp As PowerPoint.Application

    On Error Resume Next  '取得エラー時に次へ
    Set ppApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意

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

    'Sheets.Add After:=ActiveSheet   'シートを新規で追加するのもアリ？お任せします

    Cells.ClearContents     'アクティブシートを※勝手に全クリアして書き込むので※※注意
    Range("A1").Select
    '見出しを書き込む
    Range("A1") = "Page番号"
    Range("B1") = "名前 Shape.Name"
    Range("C1") = "テキスト objShape.TextFrame.TextRange.Text"

    Dim p As Integer, y As Integer   'pページ、y行
    Dim objShape 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  'オブジェクトの名前
         
            'オブジェクトがテキストを持っているか？チェックしてからセット
            If objShape.HasTextFrame = msoTrue Then 'テキストフレームあり
                If objShape.TextFrame.HasText = msoTrue Then 'テキスト範囲あり
                    Cells(y, "C") = objShape.TextFrame.TextRange.Text 'C列へテキスト
                End If
            End If
            
            y = y + 1   'セットする行を次へ
            
        Next
    Next
    
    '最後に列幅の自動調整 と思ったら、C列は文字数が多くてやらないほうがよかった
    Columns("A:B").EntireColumn.AutoFit  '名前のB列だけやったほうがいいかも
    Columns("C:C").ColumnWidth = 24   'AutoFitでひどい目にあったのでテキストは固定24
    
    MsgBox "処理終了"
    
End Sub

---

PowerPoint VBA 過去記事:
ken3memo.hatenablog.com
ken3memo.hatenablog.com
ken3memo.hatenablog.com

テストでSTOP止め、確認

'テストで現在選択中のスライド内のテキストを表示する
'.Shapes から テキストフレーム テキスト範囲 が あったら、表示
Sub testスライド内テキストをDebugPrint()

    Dim nPAGE As Integer
    Dim objShape As Shape
    
    nPAGE = ActiveWindow.Selection.SlideRange.SlideIndex '選択しているページ
    
    'テストで選択ページの.Shapesを探る
    For Each objShape In ActivePresentation.Slides(nPAGE).Shapes
        Debug.Print
        Debug.Print "Shape.Name:" & objShape.Name
        Debug.Print "Shape.HasTextFrame:" & objShape.HasTextFrame
        
        If objShape.HasTextFrame = msoTrue Then 'テキストフレームあり
            Debug.Print ".HasTextFrame.HasText:" & objShape.TextFrame.HasText
            If objShape.TextFrame.HasText = msoTrue Then 'テキスト範囲あり
                Debug.Print ".TextFrame.TextRange.Text:" & objShape.TextFrame.TextRange.Text
            End If
        End If
        
        '↓は、無くても当然OKです、ウザい時は外す
        objShape.Select  'わかりやすいように該当オブジェクトを選択
        Stop  '止める
    Next

    MsgBox "終了"
End Sub