知り合いが「パワーポイントでノート部分のテキストを読み上げて自動的にスライド送りする」マクロ（VBA）を作成したいんだけど・・・うまくいかない。という相談にのりました。
1枚目のスライドには処理開始ボタンを配置する。
2枚目以降のスライドのノート部分には読み上げるテキストを記述。
1枚目の処理開始ボタンクリックで読み上げ＋スライド送りを自動実行という仕様。
こんな感じで作成してみました。かなり適当です。
’ このサブがボタンクリック時にコールされるように実装してください。
Sub startSlide()
Dim n As Long
sn = ActivePresentation.Slides.Count
Debug.Print sn
'ActivePresentation.SlideShowSettings.Run
With ActivePresentation.SlideShowSettings
.RangeType = ppShowSlideRange
.StartingSlide = 2
.Run
End With
' 1枚目のスライドは開始ボタン用ページなので、２枚目のスライドから開始
For p = 2 To sn
'スライド表示と読み上げ開始が若干ずれるので、ウェイトをいれてます。。。
lag = 2
start = Timer
While Timer < start + lag
DoEvents
Wend
Application.SlideShowWindows(1).View.Next '次のページ
n = Application.SlideShowWindows(1).View.CurrentShowPosition
ret = readText(n)
Next
' 終わったらスライド１から始まるように初期化
With ActivePresentation.SlideShowSettings
.RangeType = ppShowSlideRange
.StartingSlide = 1
End With
End Sub
’ ノートのテキストを読み上げるファンクション。win10ようなので、ご注意ください。
Function readText(n As Long) As Boolean
'' ノート欄の文字列を取得
Dim strNote As String
strNote = ActivePresentation.Slides(n).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Text
'スライド表示と読み上げ開始が若干ずれるので、ウェイトをいれてます。。。
lag = 2
start = Timer
While Timer < start + lag
DoEvents
Wend
'' ノート欄が空の場合は，読み上げ処理を行わずに終了
If strNote = "" Then
read = FALSE
End If
'' 音声合成エンジンを取得
Dim sv As Object
Set sv = CreateObject("SAPI.SpVoice")
'' インストールされている音声合成エンジンのうち、最初に見つかった日本語のものを選択
For i = 0 To sv.GetVoices.Count - 1
If InStr(sv.GetVoices.Item(i).GetDescription, "Japanese") Then
Set sv.Voice = sv.GetVoices.Item(i)
Exit For
End If
Next
'' 日本語のエンジンが見つからなかった場合
If InStr(sv.Voice.GetDescription, "Japanese") < 1 Then
'' 発見に失敗した旨をメッセージボックスで通知
MsgBox "日本語のエンジンが見つかりませんでした。" & vbCrLf & _
"現在の設定 : " & sv.Voice.GetDescription
read = FALSE
End If
'' 音声合成実行
sv.Speak strNote
'' 音声合成エンジンを開放
Set sv = Nothing
read = TRUE
End Function