PowerPoint VBA: ページ番号と総ページ数(但し実際のページ数とは異なる)を算出するには

Question

お世話になります。PowerPoint VBAを初めていじります。

実現したいこと

PowerPoint 365 (Windows)で、現在のページ番号と総ページ番号を表示したい。
ただし、上記「現在のページ番号」「総ページ番号」は実際のスライド数とは異なる。

前提

毎週定期的にプレゼンがあるため、複数の似たようなレイアウトのスライドを何通りか作っています。
そのスライドの右上端に、テキストボックスで「xx枚目 / 全n枚」という表示を入れています。
これらは毎週手打ち(レイアウトを崩したくないので、1枚目のボックスを次頁以降にコピペ→打ち直し)でつけています。

この作業を自動化したいのですが、これにはいくつか条件があります。
・実際のスライド枚数≠枚数を表示したいスライドの数ではないので、上記「ページ番号を表示したいテキストボックス」が存在するページのみカウントして、その総ページ数を上記「n」にしたい
・同じ理由で、上記「xx」はページ番号を表示したいテキストボックスのカウント(現在のボックスは1枚目から数えて何番目のボックスか)としたい
・背景色(貼り付けた写真等を含む)に応じて文字色を変えているので、ボックス自体は自動生成ではなく、別スライドに準備した3通りのテンプレからコピペして手動で貼り付けたい

スライド表示時のタイムラグを極力廃したいので(自分が聴衆だったらそれでイライラしそうなので)、ページ数を算出するタイミングは各スライドの表示時ではなく「スライドの保存時」もしくは「最初の1枚を表示したとき」にしたいと考えています。

発生している問題・エラーメッセージ

該当のソースコード

試したこと

Excel/Access VBAを過去に使っていたため、VBAで何とかなるかと思ったのですが、PowerPoint VBAの仕様がどうにも分からず弱っています。どこに何を書いたら良いかすら分かっておりません。

補足情報（FW/ツールのバージョンなど）

なし

Answer 1

Sub sample()
    Dim sl, sh, k
    With CreateObject("Scripting.Dictionary")
        For Each sl In ActivePresentation.Slides
            For Each sh In sl.Shapes
                If sh.Name Like "TextBox*" And sh.Left > 700 And sh.Top > 300 Then .Add .Count + 1, sh
        Next sh, sl
        For Each k In .Keys
            .Item(k).TextFrame.TextRange.Text = k & "/" & .Count
        Next
    End With
 End Sub

Comments

[Cystidia]

ありがとうございます！試してみます！
質問したにもかかわらず、その後全く手をつけられていませんでした。

[Cystidia]

ありがとうございます。おかげさまで解決しました！

Answer 2

リファレンスは見ていますか？
https://learn.microsoft.com/ja-jp/office/vba/api/overview/powerpoint
「マクロの記録」機能が無いのでちょっとつらいですが、Excel VBAで図形を扱った経験があればリファレンスを見ればわかるかと思います。

「ページ番号を表示したいテキストボックス」を他のテキストボックスと何を以て区別するかは考える必要がありますが、

ActivePresentation.Slides(1).Shapes(1).TextFrame.TextRange.Text

で、ページ1の最初の図形のテキストを参照・代入出来ます。

Comments

[otn]

実行を手動でなく、「ファイルを開いたときに自動実行」したいということであれば、Excelのように簡単にはいかないようですが、「vba ファイルを開いたとき powerpoint」で検索すると方法はあるようです。

Answer 3

頂いたコードを参考に、最終的にこんな感じにしました。
後半で面倒くさい置換をしているのは、これ以外の方法だとフォントサイズ・色などが崩れたためです。

Sub UpdateTextBoxesWithNumericValues()
    Dim sl As Slide
    Dim sh As Shape
    Dim k As Variant
    Dim dict As Object

    Set dict = CreateObject("Scripting.Dictionary")

    For Each sl In ActivePresentation.Slides
        For Each sh In sl.Shapes
            If sh.Type = msoTextBox And sh.Top < 10 Then
                dict.Add dict.Count + 1, sh
                sh.Top = 0
            End If
        Next sh
    Next sl

    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    regex.Global = True
    regex.IgnoreCase = True
    regex.Pattern = "\b\d{1,2}\b" ' 1桁または2桁の数値にマッチする正規表現パターン

    For Each k In dict.Keys
        Dim txtRange As TextRange
        Set txtRange = dict.Item(k).TextFrame.TextRange

        If regex.Test(txtRange.Text) Then
            Dim matches As Object
            Set matches = regex.Execute(txtRange.Text)

            Dim xxStart As Long
            Dim yyStart As Long
            Dim xxValue As String
            Dim yyValue As String
            Dim foundXX As Boolean
            foundXX = False

            For Each match In matches
                If Not foundXX Then
                    xxStart = match.FirstIndex + 1
                    xxValue = match.Value
                    foundXX = True
                Else
                    yyStart = match.FirstIndex + 1
                    yyValue = match.Value
                    Exit For
                End If
            Next match

            ' XXの置換
            If xxStart > 0 Then
                With txtRange.Characters(xxStart, Len(xxValue))
                    .Text = Format(k, "00")
                End With
            End If

            ' YYの置換
            If yyStart > 0 Then
                With txtRange.Characters(yyStart, Len(yyValue))
                    .Text = Format(dict.Count, "00")
                End With
            End If
        End If
    Next k
End Sub