XXXXXさんへ PowerPointのノート読み上げと同時に字幕っぽくテキスト文字を表示自動ナレーションと字幕もどき

>パワーポイントノートに記入した内容をナレーションと字幕にしたい

と要望をいただいたので、
マクロで作成・チャレンジしてみました。

と言っても、前回作成( 2022/09/07 )のマクロ
マクロパワーポイントでノートを読み上げ PowerPoint VBA SAPI.SpVoice Speak デバッグマクロ作り方・使い方
https://www.youtube.com/watch?v=mLUdzmReyCU
に
(↑音読処理 CreateObject("SAPI.SpVoice")で処理した元になった上記動画もヨロシク)

ノートを行単位
改行コード vbCR で区切って、
SAPI.SpVoiceで読み上げと用意したテキストボックスに代入しただけです。

動画で設置方法や仕組みを解説しました。コードと合わせてみてください。
youtu.be
https://youtu.be/uXi1QJyPbTU
目次
00:00 作成結果を先に見せる
00:41 1.表示場所テキスト字幕エリアを設置します
01:58 2.アイコンなど、マクロの起動ボタンを設置します
04:47 字幕のフォント変更など微調整する方法
06:56 3.マクロ VBA コードの説明を軽く
12:00 4.あっ、マクロの設置方法を忘れてた・・・
17:39 5.おわりの挨拶アレンジ方法

#PowerPoint #パワーポイント #ナレーション
#パワポ #ノート #読み上げ #字幕
#VBA #PowerPointVBA #マクロ
#作成方法 #設置手順

0.作成結果を先に見せる
動画の冒頭でサヨナラが多いので、
先に結果を見せて、10秒でもひっぱる。
なんて、私の願望、心の話は置いといて

1.字幕を表示させたい場所にテキストボックスを設置します

テキストボックスを設置して、
名前をテキスト字幕エリアとします。
1.1 挿入テキストボックスで追加して、枠を作ってから
1.2 配置オブジェクトの選択と表示から
　　名称をテキスト字幕エリアとします

2.アイコンなど、マクロの起動ボタンを設置します

作成した読み上げマクロを起動したいので、
2.1 起動用のアイコンなどを設置します。
2.2 設置後、挿入動作からマクロを登録します。

3.コードの説明を軽く

仕組みは単純で表示中のスライドからノート文字列を取得後
Split 関数で行単位に分けて
1行単位でループして、
字幕エリアに文字列のセットと読み上げを繰り返しただけです。

'取得したノートを改行 CR で区切る
    Dim txtLINE As Variant  'Splitの結果を受け取りたいのでVariant
    txtLINE = Split(strNOTE, vbCr) '単純にSplitでCR区切りの配列を作成

改行で分解して、表示と音読をセットでループしただけでした。

    '単純にSAPI.SpVoiceを使用してみた
    Dim objSAPI As Object
    Set objSAPI = CreateObject("SAPI.SpVoice")
    
    For n = 0 To UBound(txtLINE)  '単純に配列数分 文字列セットと読み上げを繰り返す
        Debug.Print n, txtLINE(n)
        objTextShp.TextFrame2.TextRange.Text = txtLINE(n) '字幕のセット
        DoEvents
        objSAPI.Speak txtLINE(n)   '.Speakに文字列を渡し読み上げる
        DoEvents
    Next

4.あっ、マクロのコピー方法を説明してなかった・・

いきなり、説明始めたけど、
設置方法のマクロのコピペを忘れていた

下記のコードをコピー後、
貼り付けたいパワポを開き、
Alt+F11 でマクロ編集画面を起動して、
挿入標準モジュールで枠を作成してから、
貼り付けます。

その後、テキストボックスやアイコンを追加して、テストします。

保存するときは、マクロ有効のファイル形式で保存します。

なんて、言っても・・？？？ですよね。

初めから、やってみますね。
※動画 12:00～
https://www.youtube.com/watch?v=uXi1QJyPbTU&t=720s
↑設置方法を見てください。

'下記のコードをコピー
'Win10 MS365のPowerPointでテスト
Sub 現在スライドノート読み上げとテキストセット()
    
    Dim strNOTE As String   '読み上げたいノートの文字列

    'コードが長いけど、現在のスライドノートを取得
    '...Placeholders(2)なんで2？これで取得できるので・・・
    strNOTE = SlideShowWindows(1).View.Slide.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Text
    Debug.Print "ノート:" & strNOTE

    'ノートが空白なら終了
    If strNOTE = "" Then
        MsgBox "ノートが見つかりません"
        Exit Sub  'メッセージ
    End If

    '↑上で取得したノートを改行 CR で区切る
    Dim txtLINE As Variant  'Splitの結果を受け取りたいのでVariant
    txtLINE = Split(strNOTE, vbCr) '単純にSplitでCR区切りの配列を作成

    '字幕を表示するテキストボックスを存在チェックを兼ねて事前代入
    Dim objTextShp As Shape   '字幕の表示エリアを入れる
    Set objTextShp = Nothing  'チェックを兼ねて初期化
    On Error Resume Next  'エラーが発生しても強引に次の命令に行け
    '"テキスト字幕エリア" って固定名のテキストボックスを代入する
    Set objTextShp = SlideShowWindows(1).View.Slide.Shapes("テキスト字幕エリア")
    On Error GoTo 0  'ここから先は、いつものエラー処理に忘れないで戻すぞ
    If objTextShp Is Nothing Then 'Nothing=テキストボックスが用意されていない時は
        MsgBox "テキスト字幕エリア の名称で表示場所のTextBoxを用意してください"
        Exit Sub  'メッセージ
    End If
    
    'やっとノート読み上げ と 字幕をセット
    Dim n As Integer 'ラインのカウンター

    '単純にSAPI.SpVoiceを使用してみた
    Dim objSAPI As Object
    Set objSAPI = CreateObject("SAPI.SpVoice")
    
    For n = 0 To UBound(txtLINE)  '単純に配列数分 文字列セットと読み上げを繰り返す
        Debug.Print n, txtLINE(n)
        objTextShp.TextFrame2.TextRange.Text = txtLINE(n) '字幕のセット
        DoEvents
        objSAPI.Speak txtLINE(n)   '.Speakに文字列を渡し読み上げる
        DoEvents
    Next
    objTextShp.TextFrame2.TextRange.Text = "字幕の表示エリア" 'ループを抜けたら、クリアしとく
    
    Set objSAPI = Nothing

End Sub
'ここまで