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

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

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

1 環境
2 プログラムを含むPowerPointファイル
3 テーマのスライドマスターのVBAプログラム
4 「タイトルとコンテンツレイアウト」スライドマスターのVBAプログラム

環境

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

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

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

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

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

ノート読み上げ機能を含むPowerPoint

1 ファイル 685.93 KB

ダウンロード

ボタンの機能

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

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

ボタンの配置

スライドマスター

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

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

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

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

スライド

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

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

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

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

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

Sub SpeakButtonOnMaster_Click()
    Call SpeakNote
End Sub

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

Sub SpeakButtonOnMaster_Click()

Call SpeakNote

End Sub

Sub StopButtonOnMaster_Click()

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

RequestStop

End Sub

フラグ

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

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

1 2	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

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

' 見つからなかったら 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

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

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 '非同期処理を行う

'完了を待たないようにして、読み上げ中止ができるようにする

' 読み上げの完了を待つ

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

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

Next aShape

' 音声合成エンジンを解放する

Set ttsEngine = Nothing

SpeakingFlag = False

Skip:

End Sub

読み上げ中止要求

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

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

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

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

Private Sub SpeakButtonOnMaster_Click()

Call SlideMaster.SpeakNote

End Sub

Private Sub StopButtonOnMaster_Click()

Call SlideMaster.RequestStop

End Sub

寺尾隆宏より:

2021年1月19日 06:50

労作ありがたく組み込んで試作してみました。
使用方法：改ページと起動ボタンを2回押すのは煩わしいですね。最終的には自動で最後まで行くモードも欲しいですね。
ちょっとアレンジして改ページで自動開始にしてみたところ、遅い。表示がずれる。相当大変そう。

合成品質：　漢字の読み間違いが相当気になります。登録しても直らない？直ったとしても、PCを変えるとまた元の木阿弥？
イントネーションが相当おかしい。グーグルのTTSを組み込むことは可能でしょうか？
　最近のものは合成品質が相当上がっていると思いますが。
Slideに入っているマクロは使いませんでした。それでいいですよね？（ちょっと分かり難いかもです。）

返信
さーさんより:

2021年2月13日 14:33

私も改ページで自動開始試してみました。
試行錯誤した結果、1枚目じゃない限り、1枚戻して、1枚めくってしゃべるという方法でうまくいきました。
スライドショーの画面切替の設定なんかは、パワポそのものの機能で設定すればできますし、ビデオオブジェクトなんかを挿入したときに、VBAで最後まで実行しようとすると干渉するのか、パワポ自体が落ちてしまうような症状が出ました。
やっぱりシンプルなのがいいですね。

Sub OnSlideShowPageChange(ByVal Wn As SlideShowWindow)
'スライドの遷移が起きたら、読み上げを中止する
RequestStop
SpeakingFlag = False
If Not SlideShowWindows(1).View.CurrentShowPosition = 1 Then
Application.SlideShowWindows(1).View.Previous
Application.SlideShowWindows(1).View.Next
End If
Call SpeakNote
End Sub

返信
maxinjp より:

2021年3月19日 11:55

ノート読み上げ機能を利用したい場合は、通常のPPTではなく、「ノート読上げ機能付きPPT」ソフトをインストールしないといけないのでしょうか？

返信
- epi より:
  
  2021年3月20日 08:03
  
  ノートなどをVBAで自動で読み上げるようにしたい場合には、マクロ(VBA)を有効にするために、拡張子をpptm(PowerPoint マクロ有効プレゼンテーション)にする必要があります。拡張子が pptx の場合にはマクロが無効化されるので、VBAが使えません。
  手動でノート部分を選択して(PowerPointの読み上げボタンを押して)音声合成機能で読み上げるだけなら、拡張子をpptmにする必要はありません。
  
  返信