PowerPoint VBA 複数の置換条件でプレゼンテーションの文字列を一括置換する

はじめに

パワーポイントでプレゼンテーション内の全てのテキストを対象に、複数の置換条件を設定し、一括置換をする方法について、考察したい。

PowerPointにおける置換方法の考察

1. Replaceメソッドの使えるオブジェクトについて

PowerPointのVBEを開き、オブジェクトブラウザーでPowerPoint内のReplaceを検索すると、以下の通りだった。

Replaceメソッドがあるのは、FontsオブジェクトとTextRangeオブジェクトのみであり、テキストを置き換えるには、TextRangeオブジェクトをReplaceメソッドを使えばよいのだろうと分かった。

　
次に、TextRangeオブジェクトをどう取得するればよいのかを考える。
同じようにオブジェクトをブラウザーでTextRangeを検索すると、以下の通りだった。

TextRangeプロパティがあるのは、TextFrame、TextFrame2オブジェクトだと分かった。
さらに、TextFrameを検索すると、以下の通りだった。

以上から、おそらく、各図形にあるTextFrameのTextRangeに対して、Replaceメソッドを使えばよいのだろうと分かった。

2. TextRangeオブジェクトをコレクション化

TextRangeオブジェクトをコレクション化して、For Each～Nextで、各TextRangeオブジェクトに対し、Replaceメソッドを実行しようと考えた。
プレゼンテーション内の図形には様々な種類がある。
色々試してみた所、TextRangeオブジェクトの取得には、Table、SmartArt、Chart、グループ化された図形、その他の図形の5つに分けて処理すればよいようだ。

①Table
Table.Rows.Item(Row番号).Cells.Item(Cell番号).Shape.TextFrame.TextRangeオブジェクトを取得する(Rowsの代わりにColumnsでもよい）。

②Chart
グラフタイトル(Chart.ChartTitle.Format.TextFrame2.TextRange)、また、TargetShape.Chart.AxesでAxesオブジェクト(軸のコレクション)を取得し、コレクション内の各軸タイトル(AxisTitle.Format.TextFrame2.TextRange）のTextRangeオブジェクトを取得する。ただし、これらのみ、TextRange2オブジェクトになる。

③SmartArt
GroupItemsからSmartArt内の図形のTextRangeオブジェクトを取得する。

④グループ化された図形
グループ化された図形の場合は、GroupItemsプロパティでグループ内の各図形を取得する。
グループ化がネストされていても、グループ内の図形は最上位のグループ内の図形として扱われるようだ。
グループ内の各図形に対しても、タイプによって、それぞれ違う処理をする必要があるので、再帰処理で、グループ内の各図形に対して、TextRangeオブジェクトを取得する処理を行うことにした。

⑤その他の図形
TextFrame.TextRangeオブジェクトを取得する。

　
以上から、TextRangeオブジェクトをコレクション化して返すFunctionプロシージャと、再帰処理用のプロシージャを作成した。

作成するTextRangeオブジェクトのコレクションは、モジュールレベル変数として宣言セクションで宣言し、再帰処理用プロシージャで各図形のTextRangeオブジェクト追加し、完成したコレクションをFunctionプロシージャで返す。

TextRangeオブジェクトをコレクション化

Private TextRangeCollection As Collection

Public Function GetTextRangeCollection(myPresentation As Presentation) As Collection

Dim TargetSlide As Slide
Dim TargetShape As Shape

    Set TextRangeCollection = New Collection
    
    For Each TargetSlide In myPresentation.Slides
        For Each TargetShape In TargetSlide.Shapes
            Call Process_GetTextRange(TargetShape)
        Next TargetShape
    Next TargetSlide
    
    Set GetTextRangeCollection = TextRangeCollection
    Set TextRangeCollection = Nothing
    
End Function


Public Sub Process_GetTextRange(TargetShape As Shape)

Dim TargetCell As CellRange
Dim TargetGroupShape As Shape
Dim TargetAxis As IMsoAxis
Dim i As Long
Dim j As Long

    Select Case TargetShape.Type
            
        Case msoTable
        
            For i = 1 To TargetShape.Table.Rows.Count
                Set TargetCell = TargetShape.Table.Rows.Item(i).Cells
                For j = 1 To TargetCell.Count
                    If TargetCell.Item(j).Shape.TextFrame.HasText Then
                        TextRangeCollection.Add TargetCell.Item(j).Shape.TextFrame.TextRange
                    End If
                Next j
            Next i
        
        Case msoChart
            
            If TargetShape.Chart.HasTitle Then
                TextRangeCollection.Add TargetShape.Chart.ChartTitle.Format.TextFrame2.TextRange
            End If

            For Each TargetAxis In TargetShape.Chart.Axes
                If TargetAxis.HasTitle Then 
                    TextRangeCollection.Add TargetAxis.AxisTitle.Format.TextFrame2.TextRange      
                End If
            Next TargetAxis
            
        Case msoSmartArt
            
            For Each TargetGroupShape In TargetShape.GroupItems
                If TargetGroupShape.TextFrame.HasText <> msoFalse Then
                    TextRangeCollection.Add TargetGroupShape.TextFrame.TextRange
                End If   
            Next TargetGroupShape

        Case msoGroup

            For i = 1 To TargetShape.GroupItems.Count
                  Call Process_GetTextRange(TargetShape.GroupItems(i))
            Next i
        
        Case Else

            If TargetShape.TextFrame.HasText <> msoFalse Then
                TextRangeCollection.Add TargetShape.TextFrame.TextRange
            End If
    
    End Select

End Sub

3. Replaceメソッドの使用方法

Replaceメソッドについて、下記のリファレンスから引用する。

テキストの範囲で特定のテキストを検索して、検出されたテキストを指定された文字列で置き換え、検出されたテキストの最初の出現を表す TextRange オブジェクトを返します。 何も検出されなかった場合は Nothing を返します。

つまりは、テキスト範囲の特定のテキストを検索して、最初に出現したテキストを指定した文字列に置き換えるようだ。
上記リファレンスのサンプルコードによると、Do～Loopで検索するテキストを置き換えた文字列の後からにしていき、Nothingが返されるまで検索して置き換える方法を取れば、テキスト範囲全体の置換ができる。
Replaceメソッドで返されたTextRangeオブジェクトのTextRange.Startプロパティを使い、Replaceメソッドの検索開始位置(After)とすることで、最後まで検索して、置換を行うことにした（同じような仕組みのTextRange.Findのサンプルコードを参考にした）。
注意したいのが、検索開始位置(After)の指定は、どうやら0から始まるという点だ。例えば、5番目の文字からにしたい場合は4と指定しなければならない。
　

参考にしたTextRangeオブジェクトのFindメソッドのサンプルコードを以下に示す。

次の使用例は、作業中のプレゼンテーションで、"CompanyX" と完全に一致する単語をすべて検索し、太字として書式設定します。

Findメソッド サンプルコード

For Each sld In Application.ActivePresentation.Slides 
    For Each shp In sld.Shapes 
        If shp.HasTextFrame Then 
            Set txtRng = shp.TextFrame.TextRange 
            Set foundText = txtRng.Find(FindWhat:="CompanyX") 
            Do While Not (foundText Is Nothing) 
                With foundText 
                    .Font.Bold = True 
                    Set foundText = _ 
                        txtRng.Find(FindWhat:="CompanyX", _ 
                        After:=.Start + .Length - 1) 
                End With 
            Loop 
        End If 
    Next 
Next

また、TextRange.Startプロパティについて、リファレンスから引用する。

テキストを含む図形内の最初の文字を基準にして、指定したテキスト範囲内の最初の文字の位置を取得します。 値の取得のみ可能です。

Replaceメソッドで返されたTextRangeオブジェクトのStartプロパティは、検索対象のTextRangeオブジェクト全体の最初の文字を基準にして、置き換えた文字列の最初の文字の位置になっている。この位置に、置き換えた文字列の文字数を足した位置から、再度、検索すればよい。ReplaceメソッドのAfterの指定は0から始まるため、-1で調整する。

　
以上から、以下の置換実行用プロシージャを作成した。

置換実行用

Sub Run_Replace()

Dim i As Long
Dim TextRangeCollection As Collection
Dim Conditions As Collection

    Set TextRangeCollection = GetTextRangeCollection(ActivePresentation)
    Set Conditions = New Collection
    
    '検索する単語、置き換えたい単語
    Conditions.Add Array("うえ", "した")
    Conditions.Add Array("きく", "ゆり")

    For i = 1 To Conditions.Count    
        Call Prosess_Replace(TextRangeCollection, Conditions(i)(0), Conditions(i)(1))
    Next i
    
    Set Conditions = Nothing
    Set TextRangeCollection = Nothing
    
End Sub


Sub Prosess_Replace(TextRangeCollection As Collection, TargetWord As Variant, ReplaceWord As Variant)

Dim TargetTextRange As Object
Dim ReplaceTextRange As Object
   
    For Each TargetTextRange In TextRangeCollection
        Set ReplaceTextRange = TargetTextRange.Replace(TargetWord, ReplaceWord, MatchCase:=msoTrue)
        Do Until ReplaceTextRange Is Nothing
            Set ReplaceTextRange = TargetTextRange.Replace(TargetWord, ReplaceWord, ReplaceTextRange.Start + ReplaceTextRange.Length - 1, MatchCase:=msoTrue)
        Loop
    Next TargetTextRange

    Set ReplaceTextRange = Nothing
    
End Sub

応用編：指定した文字を一括して上付き下付きにする

置換ではなく、指定した文字列に対して何らかの処理をしたいということもあると思う。
その場合は、TextRangeオブジェクトのFindメソッドを使用することで可能である。
今回は、指定した文字列の指定した文字を上付き下付きにしてみたいと思う。

TextRange.Fontオブジェクトには、Superscriptプロパティ(上付き)、Subscriptプロパティ(下付き)があるが、上付き下付きで処理を変えるのが面倒なため、BaselineOffsetプロパティ(相対位置を指定して上付き下付きにする)を使うことにした。
Superscriptプロパティ(上付き)は、BaselineOffsetプロパティを0.3に、Subscriptプロパティ(下付き)は、-0.25に自動設定するとのことだったので、それらの値をBaselineOffsetプロパティで指定することにした。

Findメソッドを使用する上で、注意したいのが、TextRangeオブジェクトとTextRange2オブジェクトでは、検出されなかった場合に戻ってくる値が違う点だ。
TextRangeオブジェクトでは「Nothing」が返るが、TextRange2オブジェクトでは、なぜか長さ0の文字列「""」が返る。
TextRangeオブジェクトをコレクション化した際に、グラフタイトル、軸タイトルだけは、TextRange2オブジェクトとなっていた。
そのため、「Nothing」と「""」の両方の確認が必要になる。
Replaceメソッドでは、TextRange2オブジェクトでも「Nothing」が返るので、できれば、Findメソッドでも同じように「Nothing」が返るようにして欲しいのだが…。

以上から、以下の実行用プロシージャを作成した。

上付き下付き変更

Sub Change_BaselineOffset()

Dim i As Long
Dim TextRangeCollection As Collection
Dim Conditions As Collection

    Set TextRangeCollection = GetTextRangeCollection(ActivePresentation)
    Set Conditions = New Collection
    
    '検索する単語、検索した単語の上付き・下付きにしたい文字の位置、文字の長さ、上付き・下付きの相対位置
    '（相対位置は、下付き：-0.25、上付き：0.3が基本）
    Conditions.Add Array("CO2", 3, 1, -0.25)
    Conditions.Add Array("m2", 2, 1, 0.3)
    Conditions.Add Array("m3", 2, 1, 0.3)
    Conditions.Add Array("H2O", 2, 1, -0.25)
    
     For i = 1 To Conditions.Count
        Call Prossess_BaselineOffset(TextRangeCollection, Conditions(i)(0), Conditions(i)(1), Conditions(i)(2), Conditions(i)(3))
    Next i

    Set Conditions = Nothing
    Set TextRangeCollection = Nothing
    
End Sub


Sub Prossess_BaselineOffset(TextRangeCollection As Collection, TargetWord As Variant, Start As Variant, Length As Variant, Size As Variant)

Dim TargetTextRange As Object
Dim ChangeTextRange As Object
    
    For Each TargetTextRange In TextRangeCollection
    
        Set ChangeTextRange = TargetTextRange.Find(TargetWord, MatchCase:=msoTrue)
        If Not ChangeTextRange Is Nothing Then
            If ChangeTextRange <> "" Then
                ChangeTextRange.Characters(Start, Length).Font.BaselineOffset = Size
            End If
        End If
        
        Do Until ChangeTextRange Is Nothing
            If ChangeTextRange <> "" Then
                Set ChangeTextRange = TargetTextRange.Find(TargetWord, ChangeTextRange.Start + ChangeTextRange.Length - 1, MatchCase:=msoTrue)
            Else
                Exit Do
            End If
            
            If ChangeTextRange Is Nothing Then Exit Do
            If ChangeTextRange = "" Then Exit Do
            ChangeTextRange.Characters(Start, Length).Font.BaselineOffset = Size
        Loop
        
    Next TargetTextRange
    
    Set ChangeTextRange = Nothing
    
End Sub