音声での説明があった方が良いPowerPointのスライドを作る必要がある。

原稿はつくるとして自分で読み上げると、録音のための環境が整っていないので、周囲からの音が問題になった場合には、録音を繰り返さなければならない。面倒で時間がかかる。

自分の声である必要は必ずしもないので、音声合成を利用してノートの原稿を読み上げ、それをスライドに埋め込むことにした。音声の必要がなければノートを読めばよいし、ノートを読むのが面倒であれば音声を再生して聞けばよい。

Windowsで、VBAとText-to-Speech(TTS)エンジンを使って読み上げをするプログラムはあったが、複数のスライドを一括して処理するものが見つけられなかったので作成してみた。

環境

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

音声合成で利用できる音声は次の通り。下記のVBAプログラムでは日本語の男性の声としてMicrosoft Ichiro が使われた。

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

ノート読み上げPowerPoint

1 ファイル 722.60 KB

ダウンロード

スライドのノートを音声合成エンジンで読み上げたものをスライドに埋め込むことをすべてのスライドで行うVBAを利用したプログラムの例を示す。

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

スライドショーを実行して最初のスライドにある「音声ファイルの作成・挿入」ボタンを押すと、読み上げた音声ファイルが埋め込まれる。

音声ファイルを一括して削除したい場合には、スライドショーを実行して、最初のスライドにある「音声ファイルの削除」ボタンを押す。

作成したPowerPointファイルをスライドショーにして、クリックなどでスライドを変えた場合に自動的に音声ファイルの再生を行うようにすると速く読み進めるのの邪魔になるので、例では、スライドの左上の再生ボタンを押さないと音声は出ないようにした。

VBAプログラム

「音声ファイルの作成・挿入」ボタンは、オブジェクト名 AddAudioFilesButton とした。スライドショーなどでボタンをクリックすると AddAudioFilesButton_Click() が呼び出される。そこから AddAudioFiles() が呼び出されて処理が進む。

「音声ファイルの削除」ボタンは、オブジェクト名 RemoveAudioFilesButton とした。スライドショーなどでボタンをクリックすると RemoveAudioFilesButton_Click() が呼び出される。そこから、RemoveAudioFiles() が呼び出されて処理が進む。

Private Sub AddAudioFilesButton_Click()
    Call AddAudioFiles
End Sub

Private Sub RemoveAudioFilesButton_Click()
    Call RemoveAudioFiles
End Sub

音声ファイルの作成・挿入

GetTtsEngine()で、指定された言語と性別の音声を合成できるText-To-Speech エンジンを取得する。

スライドを順番にみていき、ノート部分をMakeSpeechText() で必要に応じて編集して、MakeFileName()で音声ファイル名を生成し、Speak()で発生して、音声ファイルに保存する。

InsertAudio()で作成した音声ファイルをスライドに追加する。

Private Sub AddAudioFiles()
    ' 音声合成エンジンを取得する
    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
    
    For Each aSlide In ActivePresentation.Slides
        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
                        speechText = MakeSpeechText(strNotesText, slideNo)
                        ' ファイル名
                        Dim fileName As String
                        fileName = MakeFileName(slideNo)
                        ' 発声させてファイルを作成
                        Call Speak(ttsEngine, speechText, fileName)
                        ' ファイルをスライドに追加
                        Call InsertAudio(fileName, aSlide)
                    End If
                End If
            End If
        Next aShape
    Next aSlide
    
    ' 音声合成エンジンを解放する
    Set ttsEngine = Nothing
End Sub

音声ファイルの作成で利用されるプログラム

MakeSpeechTextは、テキストとスライド番号から発話用のテキストをつくる。スライド番号を使用している箇所はコメントアウトされていて使われていない。音声ファイルが正しくスライド番号と対応しているかをスライド番号を最初に読み上げることで確認する際に使用した。

Private Function MakeSpeechText(ByVal text As String, ByVal slideNumber As Integer)
    Dim speechText As String
    Dim prefixText As String
    
    '' ページ番号を最初に読み上げる?
    ''prefixText = Str(slideNumber) & "ページ。" & text
    prefixText = ""
        

    If text = "" Then
        ' 発話内容が空の場合には prefixTextも読まない
        speechText = ""
    Else
        ' 発話テキストを作成
        speechText = prefixText & text
    End If
    MakeSpeechText = speechText
End Function

Private Function MakeFileName(ByVal slideNumber As Integer)
    'ファイル名を作成
    fileName = "slide" & CStr(slideNumber) & ".wav"
    MakeFileName = fileName
End Function

Private Sub Speak(ByRef ttsEngine, ByVal speechText As String, ByVal fileName As String)
    Const SAFT8kHz8BitMono = 4
    Const SAFT48kHz16BitMono = 38
    Const SAFTGSM610_8kHzMono = 64
    Const SSFMCreateForWrite = 3 ' Creates file even if file exists and so destroys or overwrites the existing file

    Dim aFileStream
    
    Set aFileStream = CreateObject("SAPI.SpFileStream")
    ' 48kHz 16bit Mono PCM
    'aFileStream.Format.Type = SAFT48kHz16BitMono
    ' 8kHz GSM6.10 Mono (圧縮形式)
    'aFileStream.Format.Type = SAFTGSM610_8kHzMono
    ' 8kHz 8bit Mono PCM
    aFileStream.Format.Type = SAFT8kHz8BitMono
    
    ' ファイルの作成(存在したら上書き　SSFMCreateForWrite)
    Call aFileStream.Open(fileName, SSFMCreateForWrite)
    'oFileStream.Open fileName, SSFMCreateForWrite
    ' オーディオストリームの出力をファイルに設定
    Set ttsEngine.AudioOutputStream = aFileStream
    
    ' 音声合成実行
    ttsEngine.Speak speechText
    
    ' ファイルを閉じる
    aFileStream.Close
End Sub

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 が使えない)
    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

    If voice Is Nothing Then
        ' 目的の音声が見つからなかった場合
        Set ttsEngine = Nothing
    End If
    Set GetTtsEngine = ttsEngine
End Function

音声ファイルの挿入で利用されるプログラム

InsertAudioで指定の音声ファイルをスライドに追加する。

スライドが切り替わった際に音声ファイルが自動的に再生されるようした場合も試してみたが、利用形態に合わないと思われるのでコメントアウトしている。音声の自動再生を有効にする場合には、再生ボタンがスライドショーの時に見えないようにしても良い。

Sub InsertAudio(fileName As String, aSlide As Slide)
    Dim aShape As Shape
    'Dim anEffect As Effect
    
    ' 音声ファイルをスライドに追加する
    '' False, True で音声ファイルをPowerPointに埋め込む
    '' 10,10 は再生ボタンの座標(x=10,y=10で左上に表示されるはず)
    Set aShape = aSlide.Shapes.AddMediaObject2(fileName, False, True, 10, 10)
    
    ' 音声ファイルが自動的に再生されるようにする
    'Set anEffect = aSlide.TimeLine.MainSequence.AddEffect(aShape, msoAnimEffectMediaPlay, , msoAnimTriggerWithPrevious)
    '' anEffect.MoveTo 1 '一番最初のエフェクトにする
    
    'スライド ショーの実行時は再生時にのみ出力される
    'anEffect.EffectInformation.PlaySettings.HideWhileNotPlaying = True
End Sub

音声ファイルの削除

スライドを順番にみていき、サウンドファイルがあったら削除する。

Private Sub RemoveAudioFiles()
    ' スライドからメディア(音声)ファイルを削除する
    Dim aSlide As Slide
    Dim aShape As Shape
    
    For Each aSlide In ActivePresentation.Slides
        For Each aShape In aSlide.Shapes
            If aShape.Type = msoMedia Then
                If aShape.MediaType = ppMediaTypeSound Then　' サウンドファイル
                    ' 音声ファイルを削除
                    aShape.Delete
                End If
            End If
        Next aShape
    Next aSlide
End Sub