「ノート読み上げを含むPowerPoint」で、PowerPointのノートを音声合成で読み上げて、音声ファイルを生成し、それをスライドに埋め込むようにしてみた。しかし、音声ファイルを使うので、PowerPointファイルが大きくなってしまう。

環境を Windows10のPowerPointに限定すれば、音声ファイルを埋め込む必要はなく、必要に応じて音声合成することができる。そのようすれば、音声でPowerPointファイルが大きくなることを防ぐことができる。

そこで、スライドマスターにボタンを配置して、スライドショーの際にボタンを表示し、ボタンで読み上げを制御するようにしてみた。

環境

「ノート読み上げを含むPowerPoint」と同じ。

• Windows 10 Home 1909
• PowerPoint  for Microsoft 365 バージョン 2008 (ビルド 13127.20409) 64bit

プログラムを含むPowerPointファイル

音声合成エンジンでスライドのノートを読み上げる制御をボタンで行うVBAプログラムの例を示す。

VBAを利用しているのでマクロ実行を有効にしないと動作しない。

ボタンの機能

スライドショーを実行するか閲覧表示にして、各スライドにある「ノート読み上げ」ボタンをクリックすると、スライドのノートが読み上げられる。

各スライドにある「読み上げ中止」ボタンをクリックすると読み上げを中止する。また、スライドの遷移があった場合やスライドショーが終了した場合には読み上げを中止する。

ボタンの配置

スライドマスター

スライドマスターにボタンを配置することでスライドごとにボタンを配置しなくても良いようにしている。

まず、プレゼンテーションのテーマのスライドマスターに「ノート読み上げ」ボタンと読み上げ中止」ボタンを配置している。

１枚目のタイトルスライドは「タイトル レイアウト」スライドマスターに従っているため、ボタンを独自に配置する必要があり、そのようにしている。

プレゼンテーションのテーマのスライドマスターは、「タイトルとコンテンツ レイアウト」スライドマスターに継承されているはずであり、２枚目以降のスライドでは「タイトルとコンテンツ レイアウト」を使っているので、 ２枚目以降のスライドには自動的にボタンが表示される。

スライド

１枚目のタイトルスライドは、「タイトル レイアウト」スライドマスターに従っている。ボタンの位置でそれが確認できる。

２枚目、３枚目のスライドは、「タイトルとコンテンツ レイアウト」に従っており、１枚目とはボタンの位置が異なるが、２枚目と３枚目では同じ位置にボタンが配置される。

　

 

テーマのスライドマスターのVBAプログラム

「ノート読み上げ」ボタンは、オブジェクト名 SpeakButtonOnMaster とした。スライドショーや閲覧表示でボタンをクリックすると SpeakNote() が呼び出される。

「読み上げ中止」ボタンは、オブジェクト名 StopButtonOnMaster とした。スライドショーや閲覧表示でボタンをクリックすると RequestStop() が呼び出される。

Sub SpeakButtonOnMaster_Click()
    Call SpeakNote
End Sub

Sub StopButtonOnMaster_Click()
    '「読み上げ中止」ボタンがクリックされたら、読み上げを中止する
    RequestStop
End Sub

フラグ

読み上げの中止要求と実行状態のフラグをグローバル変数として使っている。

Dim StopRequestFlag As Boolean  '読み上げ中止要求フラグ
Dim SpeakingFlag As Boolean      '読み上げ中フラグ

音声合成エンジンの取得とその設定

GetTtsEngine()は、音声合成エンジンを取得し、必要な音声を探して設定する。手順は以下の通り。

まず、音声合成エンジンを取得する。

その後、日本語の男性のVoiceを探す。みつからない場合には、日本語の(女性の)Voiceを探す。以下のプログラムでは、日本語の男性のVoiceがみつからない場合に別のループで日本語のVoiceを探しているが、単に男性のVoiceが見つからない場合に女性で良いというのであれば、If InStr(token.GetDescription, language) Then '言語 の直後にSet voice = token を入れておくだけで良いと思う。ここでは、Voiceの探し方の備忘録として２つのループを残しておく。

Voiceが見つかったら、それを音声合成エンジンにセットし、以下のプログラムでは、読み上げの速度を少しだけ速く設定している。

Private Function GetTtsEngine(language As String, gender As String) As Object
    ' 音声合成エンジンを取得する
    Dim ttsEngine As Object
    Set ttsEngine = CreateObject("SAPI.SpVoice")
    
    
    ' gender と language に合致する音声を探す (OneCoreを含めないでGetVoicesだけでは Ichiro が使えない)
    Dim voice As Object
    Set voice = Nothing
    Set Category = CreateObject("SAPI.SpObjectTokenCategory")
    Category.SetID "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Speech_OneCore\Voices", False
    For Each token In Category.EnumerateTokens
        If InStr(token.GetDescription, language) Then   '言語
            If token.GetAttribute("Gender") = gender Then   '性別
                Set voice = token
                Set ttsEngine.voice = voice
                Exit For
            End If
        End If
    Next
    ' 見つからなかったら language に合致する音声を探す
    If voice Is Nothing Then
        For Each token In ttsEngine.GetVoices
            If InStr(token.GetDescription, language) Then   '言語
                Set voice = token
                Set ttsEngine.voice = voice
                Exit For
            End If
        Next
    End If

    If voice Is Nothing Then
        ' 目的の音声が見つからなかった場合
        Set ttsEngine = Nothing
    End If
    ttsEngine.Rate = 2 '読み上げの速度 (遅い -10～10 速い)
    Set GetTtsEngine = ttsEngine
End Function

テキストの発話

SpeakTextsは、引数で与えられたテキストを読み上げる処理をしている。

読み上げは１行ごとに行うように改行で分割している。分割する必要はないであろうが、ここでは、非常に長い文章のノートを一括して処理すると途中で中断できないことから行に分けて処理している。

１行ごとに、中止要求があるかフラグを確認し、要求があれば、発生を止めてマクロ全体の実行を止めている。DoEventsでイベント処理をし、その後StopRequestFlagを調べる。ノートが短ければ、中止ボタンを押す前に発声の処理が終わっていると思われるが、念のためにチェックをしている。

１行ごとに、ttEngine.Speakでテキストを読み上げる(要求をする)。SVSFlagsAsync(=1)フラグによって、非同期処理となり、発話が実際に終わる前に制御が戻ってくる。１行の読み上げが終わる前に次の行の処理をすることになる。

すべての行の読み上げ要求処理が終わった後に、すべての読み上げ発話が終わるの待つ。非同期処理をしているのは、読み上げ中にそれを中断することができるようにするためである。

読み上げ発話が終わるまでは一定間隔(500ms)毎に、DoEventsでイベント処理をし、StopRequestFlag が真になっていたら　ttsEngine.Speak "", SVSFPurgeBeforeSpeak 　で読み上げを中止する。

 

Private Sub SpeakTexts(ByRef ttsEngine As Object, ByVal text As String)
    Dim lines() As String
    
    Const SVSFlagsAsync = 1 '非同期
    Const SVSFPurgeBeforeSpeak = 2  'これまでの発話内容を取り除いてから発話
   
    ' 発声をしていたら一旦止める
    ttsEngine.Speak "", SVSFPurgeBeforeSpeak    ' 発声を止める
    
    '行ごとには読み上げる
    lines = Split(text, vbCr) ' 改行で分割
    For Each Line In lines
        speechText = Line
        
        DoEvents
        ' 中止要求があれば、実行を終了する
        If StopRequestFlag Then
            ttsEngine.Speak "", SVSFPurgeBeforeSpeak    ' 発声を止める
            End '全体の実行を終了させる
        End If
        ' 発声させる
        ttsEngine.Speak speechText, SVSFlagsAsync '非同期処理を行う
        '完了を待たないようにして、読み上げ中止ができるようにする
    Next
    
    ' 読み上げの完了を待つ
    Do Until ttsEngine.WaitUntilDone(500)   ' 500msごとに
        ' イベント処理を行って中断できるようにする
        DoEvents
        ' 中止要求があれば、実行を終了する
        If StopRequestFlag Then
            ttsEngine.Speak "", SVSFPurgeBeforeSpeak    ' 発声を止める
            End '全体の実行を終了させる
        End If
        Debug.Print ("."); '繰り返し毎に「.」を表示(末尾の改行なし)
    Loop
    Debug.Print ("SpeakTexts done!")
End Sub

ノートの読み上げ

既に読み上げを実行中であれば、それ以降の処理をスキップして呼び出し側に戻る。

実行中でなければ、音声合成エンジンを取得する。うまく取得できない場合にはユーザに通知する。

スライドショーで示しているスライドを取得し、そのノートをテキストとして取り出す。テキストを SpeakTexts() を呼び出すことで読み上げる。

Sub SpeakNote()
    Debug.Print ("SpeakNote()")
    If SpeakingFlag Then '既に実行中なら無視
        GoTo Skip
    End If
    StopRequestFlag = False
    SpeakingFlag = True
    
    ' 音声合成エンジンを取得する
    Dim ttsEngine As Object
    Set ttsEngine = GetTtsEngine("Japanese", "Male")
    
    ' 適切な音声エンジンが見つからなかった場合
    If ttsEngine Is Nothing Then
        ' 発見に失敗した旨をメッセージボックスで通知
        MsgBox "適切な日本語の音声が見つかりませんでした。"
        Exit Sub
    End If

    ' スライドのノートのテキストを取得して音声ファイルに変換する
    Dim aSlide As Slide
    Dim aShape As Shape
    Dim slideNo As Integer
    
    'スライドショーで示しているスライド番号を取得
    slideNo = SlideShowWindows(1).View.CurrentShowPosition
    
    Set aSlide = ActivePresentation.Slides(slideNo)
    'slideNo = aSlide.slideNumber
    For Each aShape In aSlide.NotesPage.Shapes
        If aShape.PlaceholderFormat.Type = ppPlaceholderBody Then
            If aShape.HasTextFrame Then
                If aShape.TextFrame.HasText Then
                    ' 発話テキスト
                    Dim speechText As String
                    strNotesText = aShape.TextFrame.TextRange.text
                    ' 発声させる
                    Call SpeakTexts(ttsEngine, strNotesText)
                End If
            End If
        End If
    Next aShape
    
    ' 音声合成エンジンを解放する
    Set ttsEngine = Nothing
    SpeakingFlag = False
Skip:
End Sub

読み上げ中止要求

RequestStop()は、フラグ StopRequestFlag をセットするだけ。

Sub RequestStop()
    StopRequestFlag = True
    Debug.Print ("RequestStop()")
End Sub

読み上げの中止ためのイベントハンドラ

「読み上げ中止」ボタンをクリックした以外でも、スライドの遷移があった場合やスライドショーが終了した場合には読み上げを中止するようにハンドラを定義している。

Sub OnSlideShowPageChange(ByVal Wn As SlideShowWindow)
    'スライドの遷移が起きたら、読み上げを中止する
    RequestStop
End Sub

Sub OnSlideShowTerminate(ByVal Wn As SlideShowWindow)
    'スライドショーが終わったら、読み上げを中止する
    RequestStop
End Sub

 

「タイトルとコンテンツ レイアウト」スライドマスターのVBAプログラム

ボタンがクリックされた際のハンドラのみを定義している。

SlideMasterにある、機能に対応するマクロを呼び出しているだけである。

「ノート読み上げ」ボタンは、オブジェクト名 SpeakButtonOnMaster とした。スライドショーや閲覧表示でボタンをクリックすると SlideMaster.SpeakNote() が呼び出される。

「読み上げ中止」ボタンは、オブジェクト名 StopButtonOnMaster とした。スライドショーや閲覧表示でボタンをクリックすると SlideMaster.RequestStop() が呼び出される。

Private Sub SpeakButtonOnMaster_Click()
    Call SlideMaster.SpeakNote
End Sub

Private Sub StopButtonOnMaster_Click()
    Call SlideMaster.RequestStop
End Sub