TextRange.Replaceメソッドテキストボックスに標準関数Replace関数で置換した文字をTextに戻すと装飾が外れてしまう

TextRange.Textで箇条書きや色の情報が消えて困ってます。
文字列を置換処理後、TextFrame.TextRange.Text = "置換後文字列"と単純に文字をセットすると
箇条書きや色の情報が消えてしまう。
#PowerPointVBA #TextBox #Replace #デバッグ
www.youtube.com
https://www.youtube.com/watch?v=VR1V18qbZn8
目次
00:00 1.不具合の再現 TextFrame.TextRange.Text再代入をチェックする
01:55 実行結果を見せて、不具合の説明
03:28 2.TextRange.Replace メソッドがあるので、これを使うテスト
06:44 3.ReplaceALLみたいなコマンドを探せなかったのでループで回してみた
12:06 4.おわりの挨拶

1.不具合の再現 TextFrame.TextRange.Text再代入をチェックする
https://youtu.be/VR1V18qbZn8?t=112

単純に

    Dim ppShp As PowerPoint.Shape  'シェイプ
    Set ppShp = objSlide.Shapes("TextBox 2") 'テストはTextBox 2固定でテスト

    Dim strWORK As String
    Const sFIND = "パソコン"   '探す文字列
    Const sREPLACE = "PC"      '置き換える文字列

    strWORK = ppShp.TextFrame.TextRange.Text
    
    '単純にVBA replace関数で置き換える
    strWORK = Replace(strWORK, sFIND, sREPLACE)
    
    'Shapes("TextBox 2")へ戻すセットする
    ppShp.TextFrame.TextRange.Text = strWORK

を実行すると、

あら不思議、箇条書きや色がリセットされてしまう？

2.TextRange.Replace メソッドがあるので、これを使うテスト
https://www.youtube.com/watch?v=VR1V18qbZn8&t=208s

色とか、箇条書きが消えるのは、カンベン。
文字列を置き換えるメソッドを探すと

TextRange.Replace メソッド (PowerPoint)
https://learn.microsoft.com/ja-jp/office/vba/api/powerpoint.textrange.replace
learn.microsoft.com
↑が、見つかったので、これを使用してみます。

枠外:隙あれば自分語り、↑すぐ、みつかった感じで書いてますが、
初めの計画は、Findで探して選択状態にして、
SelectionのRangeから攻めようとしたら、
辞書の隣に探していた言葉じゃないけど、
TextRange.Replace メソッドがたまたま、見つかりました。
※あぶなかったぁ、Findで選択状態にしてSelectionを操作とか、別方向に行きそうだった。

と、解説が別方向に行ったところで、

話を元に戻して、

    Dim ppShp As PowerPoint.Shape  'シェイプ
    Set ppShp = objSlide.Shapes("TextBox 2") 'テストはTextBox 2固定でテスト

    Dim strWORK As String
    Const sFIND = "パソコン"   '探す文字列
    Const sREPLACE = "PC"      '置き換える文字列
    
    Dim ppTextRange As PowerPoint.TextRange
    Set ppTextRange = ppShp.TextFrame.TextRange
    
    ppTextRange.Replace sFIND, sREPLACE

と、
.Replace で簡単に置き換えすることができました。
※変数に入れて使っていますが、
ppShp.TextFrame.TextRange.Replace sFIND, sREPLACE
で、OK、イヤ長さ気にしなきゃ
objSlide.Shapes("TextBox 2").TextFrame.TextRange.Replace sFIND, sREPLACE
でしょ。

好きな書き方で、使ってみてください。

3.ReplaceALLみたいなコマンドを探せなかったのでループで回してみた
https://www.youtube.com/watch?v=VR1V18qbZn8&t=404s

全てを置換する。って感じのパラメーターがありそうなんだけど、
探せなかったので、
ループで回してみた。

TextRange.Replaceが結果を返すので、

    '初回 ループを一回以上回したかったので、そのまま、TextRangeを代入する
    Set ppTextRange = ppShp.TextFrame.TextRange
    
    '置換結果がある間、ループする
    While Not (ppTextRange Is Nothing)  'トリッキーなループだけど
        '置換処理の実行
        Set ppTextRange = ppShp.TextFrame.TextRange.Replace(sFIND, sREPLACE)
        'なんかバカっぽいけど、↑これで、結果がNothingならループを抜けるので
    Wend

みたいにして、繰り返してみた。

4.おわりの挨拶
https://www.youtube.com/watch?v=VR1V18qbZn8&t=726s

テキストの置き換え処理で、色などの装飾が外れてしまったら、
試してみてください。

もっと、良い方法がありそうだなぁ・・と思いつつ、失礼します。
(※文章全体じゃなかった、パワポならスライド全体に置換処理を発行できたりして・・・)

'動画内で、ループを思い付きで調整したパターン
'確認テスト用 TextRange.Replace ができなくなるまでループテスト
'TextBox 2 の文章を変えてみる
Sub 置換テスト004_TextRange_Replaceをループを調整()
    
    Dim nPAGE As Integer
    nPAGE = ActiveWindow.Selection.SlideRange.SlideIndex '現在選択しているページ
    
    Dim objSlide As PowerPoint.Slide  'スライド
    Set objSlide = ActivePresentation.Slides(nPAGE) '↑現在のページを変数に
    
    Dim ppShp As PowerPoint.Shape  'シェイプ
    Set ppShp = objSlide.Shapes("TextBox 2") 'テストはTextBox 2固定でテスト

    Const sFIND = "パソコン"   '探す文字列
    Const sREPLACE = "PC"      '置き換える文字列
    
    Dim ppTextRange As PowerPoint.TextRange
    
    '置換結果がある間、ループする
    Set ppTextRange = ppShp.TextFrame.TextRange.Replace(sFIND, sREPLACE)
    While Not (ppTextRange Is Nothing)  'トリッキーなループだけど
        '置換処理の実行
        Set ppTextRange = ppShp.TextFrame.TextRange.Replace(sFIND, sREPLACE)
        'なんかバカっぽいけど、↑これで、結果がNothingならループを抜けるので
    Wend

    MsgBox "処理終了、確認してください"

End Sub