三流君 ken3のmemo置き場

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

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

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

Ken3 ホームページ 目次

分類:HPを大きく分けると4つの柱(分類)です。
・[Excel/Access VBA]の解説
・[ASP(Active Server Pages)]の解説。
・[元コンビニ店長時代の話]が弟に巻き込まれ、失敗した脱サラ、畑違い?の仕事で失敗。
・[プログラマーの愚痴]では、あまり見せたくない三流プログラマーの内面かな。
三流君を踏み台にする
主に上記4つの分類でHP作成やメルマガの発行を行ってます。
※更新頻度が落ちていて情報の鮮度が悪いです。



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