Powerpointの各スライドの各図形について、図形内のテキストに対してVBAの処理中に文字列置換を挟みたいが、Replace関数を使うとReplace関数の仕様により置換後にフォントが初期化されてしまう。これに対処するためのプログラムを関数として実装したものが以下のものである。
考え方は次の通り。
①置換対象のテキストがある図形Aをコピーペースト。ペースト後の図形をBとｓるう。
②図形Aのテキストに関して、置換対象文字を置換する
③図形Bの各文字のフォントを、図形Aの同じ位置の文字にコピーする
少し速度は遅いがおおむねこれで対応できるかなと考えている。
‘——————————-プログラムここから—————————————–
Function Fun_Replace(byval sld As Slide, byval shp as Shape, ByVal PreWord As String, ByVal AftWord As String)
‘———————説明————————————————-
‘文字の置換をVBAのReplaceで行なうとフォントの初期化がされてしまうため、
‘文字の置換をReplaceで行ないつつ、前のフォントをコピーすることで
‘フォントの復元を行う。全てのスライド、全ての文字列に対して処理する。
sldは置換する図形があるスライドオブジェクト。shpは置換対象の図形のオブジェクト。
‘Preword：置換する文字列 AftWord：置換した後の文字列
‘—————————————————————————
‘s————変数宣言————-
Dim i As Integer
Dim j As Integer
Dim StartI As Integer ‘iの開始番号
Dim EndI As Integer ‘iの終了番号
Dim ShpSentence As Shape ‘元々の文章
Dim PosA As Integer ‘置換開始文字数
Dim OriLength As Integer ‘もとの文章の文字数
Dim PreLength As Integer ‘置換前の文字数
Dim AftLength As Integer ‘置換後の文字数
Dim Misalignment As Integer ‘フォント位置をずらすための関数
‘e————変数宣言————-
‘s——————–初期化————————–
PreLength = Len(PreWord) ‘置換前の文字数
AftLength = Len(AftWord) ‘置換後の文字数
‘e——————–初期化————————–
‘s———————————-メインループ—————————————
For Each sld In ActivePresentation.Slides ‘各スライドをたどる
For Each shp In sld.Shapes ‘各図形をたどる
If shp.HasTextFrame Then ‘図形でテキストボックスを持っていたら
‘s————メイン————-
If shp.TextEffect.Text Like “*” & PreWord & “*” Then ‘置換対象文字列検索
shp.Copy ‘図形のコピー
sld.Shapes.Paste ‘図形のペースト
Set ShpSentence = sld.Shapes(sld.Shapes.Count) ‘最後に追加した図形（ペーストした図形）をShpSentenceにセット
PosA = InStr(1, shp.TextFrame.TextRange.Text, PreWord) ‘置換対象文字がどこで開始しているか調べる
OriLength = Len(shp.TextFrame.TextRange.Text) ‘文章の文字数
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, PreWord, AftWord) ‘置換文字列のコピー
‘置換文字前後での処理分け
For j = 1 To 2
If j = 1 Then ‘ 置換する文字の手前までフォントをコピー
StartI = 1 ‘最初の文字列
EndI = PosA – 1 ‘置換する文字列の手前
Misalignment = 0 ‘ずれなし
Else ‘置換する文字の直後からのフォントをコピー
StartI = PosA + AftLength ‘置換する文字列の最後の直後
EndI = OriLength – (PreLength – AftLength) ‘文末
Misalignment = PreLength – AftLength ‘置換文字列の前後の文字数差
End If
‘s—————–フォント処理———————–
If EndI > 0 And StartI <> EndI Then
For i = StartI To EndI
‘フォントカラー
shp.TextFrame.TextRange.Characters(i, 1).Font.Color = ShpSentence.TextFrame.TextRange.Characters(i + Misalignment, 1).Font.Color
‘太字
shp.TextFrame.TextRange.Characters(i, 1).Font.Bold = ShpSentence.TextFrame.TextRange.Characters(i + Misalignment, 1).Font.Bold
‘フォント
shp.TextFrame.TextRange.Characters(i, 1).Font.Name = ShpSentence.TextFrame.TextRange.Characters(i + Misalignment, 1).Font.Name
‘斜体
shp.TextFrame.TextRange.Characters(i, 1).Font.Italic = ShpSentence.TextFrame.TextRange.Characters(i + Misalignment, 1).Font.Italic
‘サイズ
shp.TextFrame.TextRange.Characters(i, 1).Font.Size = ShpSentence.TextFrame.TextRange.Characters(i + Misalignment, 1).Font.Size
‘下線
shp.TextFrame.TextRange.Characters(i, 1).Font.Underline = ShpSentence.TextFrame.TextRange.Characters(i + Misalignment, 1).Font.Underline
‘陰
shp.TextFrame.TextRange.Characters(i, 1).Font.Shadow = ShpSentence.TextFrame.TextRange.Characters(i + Misalignment, 1).Font.Shadow
‘上付き
shp.TextFrame.TextRange.Characters(i, 1).Font.Subscript = ShpSentence.TextFrame.TextRange.Characters(i + Misalignment, 1).Font.Subscript
‘下付き
shp.TextFrame.TextRange.Characters(i, 1).Font.Superscript = ShpSentence.TextFrame.TextRange.Characters(i + Misalignment, 1).Font.Superscript
Next
End If
‘e——————–フォント処理————————
Next
ShpSentence.Delete ‘コピーした図形の削除
‘e————メイン————-
End If
End If
Next shp
Next sld
‘e———————————-メインループ—————————————
End Function
‘——————————————-プログラムここまで————————————–