帯

VBA PowerPointのテキスト抽出

のぶ

PowerPointのスライド上で選択したテキストボックスなどから、テキストを抽出してクリップボードにコピーするツールのご紹介です。

PowerPoint文書に記載されている文章を流用する時などに、対象のテキストが１つのテキストボックスに収まっていれば、そのテキストを１回選択コピーするだけで済みます。しかし、それが複数のテキストボックスに分かれていたりすると、選択コピーの操作を複数回行う必要があり面倒です。

そこで、PowerPoint文書にVBAプログラムを組み込んで、スライド上で選択したテキストボックスなどから、テキストを抽出してクリップボードにコピーするツールを作成してみましょう。

プログラムコードは、前回記事「10.VBA PowerPoint文書フォント変更の仕上げ」から一部流用して作成します。

新規文書の作成

まずは、テスト環境も兼ねたVBAプログラムを組み込むための新規文書を作成します。
もし、テストが可能な既存のPowerPoint文書があれば、VBAプログラムを組み込めるように、その拡張子をpptmに変更保存したものでもよいです。

PowerPointアプリケーションを起動して、空白のプレゼンテーションを選択して開きます。

内容は何でもよいのですが、サンプルとして次のようテスト文書を作成しました。

タイトルのみのレイアウトを選び、タイトルを記入、テキストボックスを２つ、SmartArtを１つ、グラフを１つ、表テーブルを１つ配置しました。

メニューから［ファイル］－［名前を付けて保存］を選択、
ファイルの種類を「PowerPoint マクロ有効プレゼンテーション (*.pptm)」、
ファイル名を「テスト.pptm」として保存します。

PowerPoint開発環境の整備

PowerPointでのVBAプログラミングを容易にするために開発環境を整えます。
PowerPointのメニューから［ファイル］－［オプション］を選択、「PowerPoint のオプション」ダイアログを表示します。

「PowerPoint のオプション」で「リボンのユーザー設定」を選択します。
右ペインの「リボンのユーザー設定」で「メイン タブ」を選択、「開発」にチェックを入れ、［OK］ボタンを押してダイアログを閉じます。

するとPowerPoint のリボンに「開発」タブが現れます。

ツールのオプション設定

「開発」タブの「Visual Basic」を選択して、「Visual Basic Editor」（以降VBEと略す）を開きます。（Alt＋F11キーでも開けます）

開いたVBEのメニューから「ツール」－「オプション」を選択します。

ツールの「オプション」ダイアログで、「自動構文チェック」のチェックを外し、「変数の宣言を強制する」をチェックして、［OK］ボタンを押してダイアログを閉じます。

標準モジュールの挿入

VBEメニューで「挿入」ー「標準モジュール」を選択します。

標準モジュールModule1が挿入されました。

プログラムコード全体

プログラムコード全体（66行）を次に示します。
これをVBEでModule1モジュールに書き込んでください。
(2019/6/14 rev.1 グラフタイトル名の抽出を修正)

Option Explicit

Dim sExtractText As String

Public Sub TextToClipboard()
    sExtractText = ""
    Call ExtractTextShapeRange(ActiveWindow.Selection.ShapeRange)
        
    Dim oClipboard As New DataObject
    oClipboard.SetText sExtractText
    oClipboard.PutInClipboard
End Sub

Private Sub ExtractTextShapeRange(oShapeRange As Object)
    Dim oShape As Object
    For Each oShape In oShapeRange
        If oShape.Type = msoGroup Then
            Call ExtractTextShapeRange(oShape.GroupItems)
        ElseIf oShape.Type = msoAutoShape Then
            Call ExtractTextShape(oShape)
        ElseIf oShape.HasSmartArt Then
            Call ExtractTextShapeRange(oShape.GroupItems)
        ElseIf oShape.HasChart Then
            Call ExtractTextChart(oShape)
        ElseIf oShape.HasTable Then
            Call ExtractTextTable(oShape)
        Else
            Call ExtractTextShape(oShape)
        End If
    Next oShape
End Sub

Private Sub ExtractTextShape(oShape As Object)
    On Error Resume Next
    Dim sText As String: sText = ""
    sText = oShape.TextFrame2.TextRange.Text
    If Trim(sText) = "" Then Exit Sub
    
    Call ExtractText(sText)
End Sub

Private Sub ExtractTextChart(oShape As Object)
    Dim sText As String: sText = oShape.Chart.ChartTitle.Text
    If Trim(sText) = "" Then Exit Sub
    
    Call ExtractText(sText)
End Sub

Private Sub ExtractTextTable(oShape As Object)
    Dim sText As String: sText = ""
    Dim oRow As Object
    For Each oRow In oShape.Table.Rows
        Dim oCell As Object
        For Each oCell In oRow.Cells
            sText = sText & oCell.Shape.TextFrame2.TextRange.Text & vbTab
        Next oCell
        sText = Left(sText, Len(sText) - 1)
        sText = sText & vbNewLine
    Next oRow
    
    Call ExtractText(sText)
End Sub

Private Sub ExtractText(sText As String)
    sExtractText = sExtractText & sText & vbNewLine
End Sub

VBEでプログラムを書き込んだイメージです。

クリップボード機能の参照設定

クリップボード機能を利用するために「Microsoft Forms 2.0 Object Library」を参照設定します。

VBEメニューで「ツール」ー「参照設定」を選択します。

参照設定ダイアログで、「参照」ボタンを押します。

「ファイルの参照」ダイアログで、ファイル名に「FM20.DLL」を入力して「開く」ボタンを押します。

「Microsoft Forms 2.0 Object Library」が参照設定されました。

プログラム動作確認

それでは動作確認してみましょう。

プログラムを組み込んだテスト文書のスライド上で、テキストを含む適当なテキストボックスなどを選択します。ここでは、先ほど作成したテスト文書のスライドで全てのオブジェクトを選択しました。

「開発」タブの「マクロ」を選択し、表示された「マクロ」ダイアログで、マクロ名「TextToClipboard」を選択、「実行」ボタンを押します。

これで、テキストボックスなどの中のテキストがクリップボードへコピーされたはずです。
メモ帳などを起動してクリップボードから貼り付けてみます。
選択したテキストボックスなどの中の一連のテキストが貼り付けられれば動作は成功です。

選択するテキストボックスを変えて色々と実行してみましょう。

プログラムの解説

それでは、プログラムの主な内容を説明しましょう。

モジュール内の変数

sExtractTextは、テキストボックスなどから抽出したテキストを、連結しながら格納する文字列変数です。

Dim sExtractText As String

TextToClipboardは、テキストを抽出してクリップボードへコピーするメイン関数です。「開発」タブの「マクロ」から呼び出せるようにスコープをPublicにしています。

Public Sub TextToClipboard()
    ：
End Sub

テキストを格納するsExtractText変数を空文字列で初期化します。
PowerPointのアクティブウィンドウで選択したシェイプの集合体からテキストを抽出します。

    sExtractText = ""
    Call ExtractTextShapeRange(ActiveWindow.Selection.ShapeRange)

クリップボードにテキストを格納するためにDataObjectを生成します。
上記で抽出したテキストをDataObjectを介してクリップボードへ格納します。

    Dim oClipboard As New DataObject
    oClipboard.SetText sExtractText
    oClipboard.PutInClipboard

ExtractTextShapeRangeは、ShapeRangeからテキストを抽出する関数です。ShapeRangeからShapeを１つずつForループで取り出して処理します。

Private Sub ExtractTextShapeRange(oShapeRange As Object)
    Dim oShape As Object
    For Each oShape In oShapeRange
    ：
    Next oShape
End Sub

Shape.TypeがmsoGroupの時はグループ化されたShapeなので、oShape.GroupItemsを引数として、自身の関数ExtractTextShapeRangeを再帰呼び出しして、グループ化されたShapeを分解します。

        If oShape.Type = msoGroup Then
            Call ExtractTextShapeRange(oShape.GroupItems)

Shape.TypeがmsoAutoShapeの時は、そのShapeからテキストを抽出します。

        ElseIf oShape.Type = msoAutoShape Then
            Call ExtractTextShape(oShape)

Shape.HasSmartArtがTrueの時はSmartArtなので、上記のグループ化されたShapeと同様に、自身の関数ExtractTextShapeRangeを再帰呼び出しして、グループ化されたShapeを分解します。
単純にSmartArtを挿入した場合は、Shape.TypeがmsoSmartArtとなりますが、プレースホルダーにSmartArtを組み込んだ場合は、Shape.TypeがmsoPlaceHolderとなり区別がつかないため、HasSmartArtプロパティの方をチェックします。

        ElseIf oShape.HasSmartArt Then
            Call ExtractTextShapeRange(oShape.GroupItems)

Shape.HasChartがTrueの時はグラフなので、ExtractTextChart関数を呼び出します。

        ElseIf oShape.HasChart Then
            Call ExtractTextChart(oShape)

Shape.HasTableがTrueの時は表テーブルなので、ExtractTextTable関数を呼び出します。

        ElseIf oShape.HasTable Then
            Call ExtractTextTable(oShape)

上記以外の場合、そのShapeからテキストを抽出します。単純なテキストボックスの場合にこの条件に来ます。

        Else
            Call ExtractTextShape(oShape)
        End If

ExtractTextShapeは、Shapeからテキストを抽出する関数です。
直線などのテキストを含まないShapeの場合も呼び出されてくるので、「On Error Resume Next」でエラーが発生しても無視するようにします。
oShape.TextFrame2.TextRange.TextプロパティでテキストをsTextに取り出します。Textプロパティにアクセスできずエラーとなった場合はsTextが空文字のままとなります。
sTextの前後のスペースをTrimで削除した上で、空文字となった場合は、そのテキストは処理対象から外します。
ExtractText関数でテキストをsExtractTextに格納します。

Private Sub ExtractTextShape(oShape As Object)
    On Error Resume Next
    Dim sText As String: sText = ""
    sText = oShape.TextFrame2.TextRange.Text
    If Trim(sText) = "" Then Exit Sub
    
    Call ExtractText(sText)
End Sub

ExtractTextChartは、グラフを処理する関数です。
グラフの場合は、そのタイトル名を抽出します。

Private Sub ExtractTextChart(oShape As Object)
    Dim sText As String: sText = oShape.Chart.ChartTitle.Text
    If Trim(sText) = "" Then Exit Sub
    
    Call ExtractText(sText)
End Sub

ExtractTextTableは、表テーブルを処理する関数です。
Forループでテーブルから行データを取り出し、さらに行データからセルを取り出しながら、各セルのテキストを抽出します。
同一行内のセルのテキスト間はタブ文字で連結します。行末尾のタブ文字は余計なので削除した上で改行文字を付加します。

Private Sub ExtractTextTable(oShape As Object)
    Dim sText As String: sText = ""
    Dim oRow As Object
    For Each oRow In oShape.Table.Rows
        Dim oCell As Object
        For Each oCell In oRow.Cells
            sText = sText & oCell.Shape.TextFrame2.TextRange.Text & vbTab
        Next oCell
        sText = Left(sText, Len(sText) - 1)
        sText = sText & vbNewLine
    Next oRow
    
    Call ExtractText(sText)
End Sub

ExtractText関数は、抽出されたテキストsTextをモジュール内変数sExtractTextに連結して格納します。

Private Sub ExtractText(sText As String)
    sExtractText = sExtractText & sText & vbNewLine
End Sub

さいごに

「VBA PowerPointのテキスト抽出」は以上です。

テストしてお気づきの方もいらっしゃるかと思いますが、選択されたShapeをShapeRangeから順番に取り出して処理しているだけなので、スライド上のテキストボックスなどの位置関係は考慮していません。そのため、抽出したテキストの並びが、スライドイメージとは上下が入れ替わっている場合もあります。

次回はこのあたりも改善してPowerPoint文書全体をWord文書に貼り付けるようなツールを作成していきたいと思います。

記事を気に入って頂き、お役に立てたら嬉しいです。