PowerPoint (一般・VBA)

PowerPoint 一般・VBAに関する話題を扱うフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : PowerPoint 2016)
PowerPoint テキストボックス内の置換について
投稿日時: 21/08/25 10:11:34
投稿者: mashimo

スライドの中のテキストボックスに複数行の文章が書かれてあり、各行でフォントサイズ・太字設定がことなっています。
マクロにてテキストを取得→修正→テキストボックスに格納すると全行同じフォント設定に変更されてしまいます。
フォント設定を変えずに文章の編集を行いたいのですが、どのようにすればよいでしょうか?
 
テキストボックス内容例(以下の3行が1つのテキストボックスに入っている)
 
1行目:大項目・・・フォント20 太字
2行目:中項目・・・フォント15 太字
3行目:小項目・・・フォント10 標準
 
 
マクロ(抽出)
    For Each sld In ActivePresentation.Slides
        For Each sh In sld.Shapes
            If sh.HasTextFrame Then
                buf = sh.TextFrame.TextRange.Text
                buf = ・・・
                sh.TextFrame.TextRange.Text = buf
      End If
        Next sh
    Next sld
 
※「buf = ・・・」の部分がなくても現象は同じ
※事情があり、上の例で3つのテキストボックスに分けるという処置はできません
 
以上、よろしくおねがいします。
 

投稿日時: 21/08/25 11:16:26
投稿者: mashimo

ためしにテキストを修正前に全文字のフォントを配列にセット、文字列修正後にフォントを再設定してみました。(下サンプルはサイズのみ)
  
方法1
  Dim f() As Font
  
  For i = 1 To Len(buf)
   ReDim Preserve f(i - 1)
   Set f(i - 1) = sh.TextFrame.TextRange.Characters(i, 1).Font
  Next
    buf=・・・(修正)
    sh.TextFrame.TextRange.Text=buf 
  For i = 1 To Len(buf)
   With sh.TextFrame.TextRange.Characters(i, 1).Font
     .Size=f(i-1).Size
   End With
  Next
  
結果
  この方法だとsh.TextFrame.TextRange.Text=bufを実行した時点で配列fの内容も書き換わってしまい、NG
  
  
方法2
  Dim fs() As Single
  For i = 1 To Len(buf)
   ReDim Preserve fs(i - 1)
   fs(i - 1) = sh.TextFrame.TextRange.Characters(i, 1).Font.Size
  Next
    buf=・・・(修正)
    sh.TextFrame.TextRange.Text=buf 
  For i = 1 To Len(buf)
   With sh.TextFrame.TextRange.Characters(i, 1).Font
     .Size=fs(i-1)
   End With
  Next
  
結果
  元のサイズが復元できました。
  
あんまりスッキリしませんが、もし根本的に文字のみ修正することができないのでしたら、上記 方法1の方法で配列fの内容を固定する方法があればその方法をご教授ください。
  
  
Set ・・・では配列の内容ではなくアドレスのみ指ししめしているのでしょうか?

投稿日時: 21/08/25 11:25:00
投稿者: mashimo

調べたらSet関数は参照しているだけなのですね。
追記した方法(フォントを書き戻す)しか無いようでしたら、必要なプロパティを実配列に残す(ディープコピー?)ことにします。

回答
投稿日時: 21/08/25 12:09:51
投稿者: んなっと

一般的な手法です。
 
test1は "桃天" を "モモ天空" に置換
test2は数字と数字以外の文字間に"-"を追加 123E →123-E
test3はInputBoxでその都度置換前と置換後を入力
 
 
Dim vbReg As Object
Sub test1()
  VB_RegALL "桃天", "モモ天空"
End Sub
Sub test2()
  VB_RegALL "(\d)(\D)", "$1-$2"
End Sub
Sub test3()
  VB_RegALL
End Sub
Sub VB_RegALL(Optional oldStr As String, Optional newStr As String)
  Dim Sld As Slide
  Dim Shp As Shape
  Dim iShp As Shape
  Dim myRow As Row
  Dim myCell As Cell
  With ActiveWindow.Selection
    If .Type = ppSelectionText Then
      oldStr = .TextRange.Text
    End If
  End With
  If oldStr = "" Then
    oldStr = InputBox("置換前", "置換前", oldStr)
    If oldStr = "" Then Exit Sub
    If newStr = "" Then
      newStr = InputBox("置換後", "置換後", oldStr)
      If StrPtr(newStr) = 0 Then Exit Sub
      If newStr = "" Then
        If MsgBox(oldStr & "を削除します。いいですか?", vbYesNo) = vbNo Then
          Exit Sub
        End If
      End If
    End If
  End If
  Set vbReg = CreateObject("VBScript.RegExp")
  With vbReg
    .Global = True
    .IgnoreCase = False
    .Pattern = oldStr
  End With
  For Each Sld In ActivePresentation.Slides
    For Each Shp In Sld.Shapes
      With Shp
        '普通のテキストボックス、図形の場合
        If .HasTextFrame Then
          With .TextFrame
            If .HasText Then
              Hennkann .TextRange, newStr
            End If
          End With
        '表の場合
        ElseIf .HasTable Then
          For Each myRow In .Table.Rows
            For Each myCell In myRow.Cells
              With myCell.Shape.TextFrame
                If .HasText Then
                  Hennkann .TextRange, newStr
                End If
              End With
            Next
          Next
        'グループの場合
        ElseIf .Type = msoGroup Then
          For Each iShp In .GroupItems
            With iShp
              If .HasTextFrame Then
                With .TextFrame
                  If .HasText Then
                    Hennkann .TextRange, newStr
                  End If
                End With
              End If
            End With
          Next
        End If
      End With
    Next
  Next
  Set vbReg = Nothing
End Sub
Private Sub Hennkann(txtRng As TextRange, newStr As String)
  Dim n As Long
  Dim myPara As TextRange
  Dim i As Long
  If vbReg.test(txtRng.Text) Then
    With txtRng
      For n = .Paragraphs.Count To 1 Step -1 '段落単位処理が安全
        Set myPara = .Paragraphs(n)
        With vbReg.Execute(myPara.Text)
          For i = .Count - 1 To 0 Step -1 '後ろからが安全
            With .Item(i)
              myPara.Characters(.FirstIndex + 1, .Length) _
              = vbReg.Replace(.Value, newStr)
            End With
          Next i
        End With
      Next n
    End With
  End If
End Sub

投稿日時: 21/08/25 14:33:51
投稿者: mashimo

んなっとさん、早速の回答ありがとうございます。
 
まだ理解が追いついていませんが、 Hennkannルーチンの中で実施しているようにParagraphs毎に分け、
Charactersで指定した範囲の文字を修正するようにすれば、フォントに影響ないということでしょうか?
 
一度、自分のソフトに組み込んで試してみます。

投稿日時: 21/08/25 15:33:53
投稿者: mashimo

んなっとさんの方法でいくつか試してみました。
  
通常文字列に関しては意図通りの変換ができ、フォントは変わることが有りませんでした。
ただし、改行コードの置換(vbCr→vbLf)を実施すると、フォントは変わりませんでしたが、置換でなく追加(?)になってしまいました。
正規表現にvbCrやvbLfは使用できないのでしょうか?
 

投稿日時: 21/08/25 15:45:18
投稿者: mashimo

ちなみにvbCr・vbLfをそれぞれ"\n""\r"に変更しても同じでした

回答
投稿日時: 21/08/25 16:29:16
投稿者: んなっと

段落単位で限定してループしているのだから当然です。
最初の質問時に置換の詳細を書くべきだったのではないですか?
   
改行も置換対象にしたいときは
     
Private Sub Hennkann(txtRng As TextRange, newStr As String)
  Dim i As Long
  With vbReg.Execute(txtRng.Text)
    For i = .Count - 1 To 0 Step -1
      With .Item(i)
        txtRng.Characters(.FirstIndex + 1, .Length) _
        = vbReg.Replace(.Value, newStr)
      End With
    Next i
  End With
End Sub
    
ただし、置換位置がずれます。少し修正が必要です。
そちらで考えてみましょう。

投稿日時: 21/08/25 20:28:02
投稿者: mashimo

>段落単位で限定してループしているのだから当然です。
考えたみればあたりまえですね。
EXCELのマクロばかり作っていて段落という考え方に馴染みが薄く気付きませんでした。
 
>最初の質問時に置換の詳細を書くべきだったのではないですか?
説明が不足していました。
様々な文字列を対象にしていますが、たまたま改行コードも統一したくて試してみました。
 
提示していただいたソースを元に考えてみます。
 
ありがとうございました。

回答
投稿日時: 21/08/25 21:05:28
投稿者: んなっと

こんな感じ。
 
Private Sub Hennkann(txtRng As TextRange, newStr As String)
  Dim i As Long
  With vbReg.Execute(Replace(txtRng.Text, vbCrLf, vbCr))
    For i = .Count - 1 To 0 Step -1
      With .Item(i)
        txtRng.Characters(.FirstIndex + 1, .Length) _
        = vbReg.Replace(.Value, newStr)
      End With
    Next i
  End With
End Sub

投稿日時: 21/08/26 09:13:10
投稿者: mashimo

 んなっとさん
おはようございます。
 
出社したらすでにソースを送っていただいていてびっくりしました。
早速、トライ・理解させていただきます。
 
今まで.NetとExcel VBAばかり手掛けていて、今回初めてPoerPointのフォーマット整形マクロを依頼されて戸惑っていました。
PowerPointのマクロに関しては情報が少ないですね。
なにか良いサイト等ありましら教えて下さい。
 
今回は貴重なアドバイスありがとうございました。

投稿日時: 21/08/26 09:27:05
投稿者: mashimo

しかしなぜテキストボックス内の文字を修正しただけで、ボックス内のフォントが全て変わってしまうのだろう?
使えない!と思っていたのですが、ふと1つのボックス内で文字毎にフォントが設定できるということは、内部はHTMLのような情報になっているはず、それをプレーンのテキストのように修正してしまうと、文字以外の情報が消えてデフォルトになってしまうのかなと推定しました。
 
今までのExcelでの業務は、あくまで情報・数値などを取り扱っており、フォントなど気にしていなかったです。
勉強しなければ・・・

回答
投稿日時: 21/08/26 11:12:52
投稿者: んなっと

123abc543a33aq
Runsメソッドというのがあって、上の文字列の場合以下の3つのTextRunに分けられます。
同一フォントがひとかたまり。
123abc
543a
33aq
 
これを利用して、フォントを絶対に変えないことを最優先にして
3aを4xyに置換。実用性は低く、使う必要は全くありません。
 
Sub test4()
  Const oldStr As String = "3a"
  Const newStr As String = "4xy"
  Dim Sld As Slide
  Dim Shp As Shape
  Dim i As Long
  For Each Sld In ActivePresentation.Slides
    For Each Shp In Sld.Shapes
      If Shp.Type = msoTextBox Then
        If Shp.TextFrame.HasText Then
          With Shp.TextFrame.TextRange
            For i = .Runs.Count To 1 Step -1
              If InStr(.Runs(i).Text, oldStr) > 0 Then
                .Runs(i).Text = Replace(.Runs(i).Text, oldStr, newStr)
              End If
            Next i
          End With
        End If
      End If
    Next
  Next
End Sub

投稿日時: 21/08/27 16:05:45
投稿者: mashimo

 んなっとさん
こちらの問題が全て解決できました。
ParagraphsやRuns、全く未知の概念でしたが、今回まさに必要な情報でした。
ありがとうございました。