https://youtube.com/clip/Ugkx1udkTfJaLJjtn0SgyfOQtCTPqGudEqyW
コードの説明を軽く↑実行結果をクリップにしてみます、合わせてみてください
仕組みは単純で 表示中のスライドからノート文字列を取得後
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
-
-
- -
-
コード全て
'下記のコードをコピー
'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
'ここまで
