音声での説明があった方が良いPowerPointのスライドを作る必要がある。
原稿はつくるとして自分で読み上げると、録音のための環境が整っていないので、周囲からの音が問題になった場合には、録音を繰り返さなければならない。面倒で時間がかかる。
自分の声である必要は必ずしもないので、音声合成を利用してノートの原稿を読み上げ、それをスライドに埋め込むことにした。音声の必要がなければノートを読めばよいし、ノートを読むのが面倒であれば音声を再生して聞けばよい。
Windowsで、VBAとText-to-Speech(TTS)エンジンを使って読み上げをするプログラムはあったが、複数のスライドを一括して処理するものが見つけられなかったので作成してみた。
目次
環境
- Windows 10 Home 1909
- PowerPoint for Microsoft 365 バージョン 2008 (ビルド 13127.20409) 64bit
音声合成で利用できる音声は次の通り。下記のVBAプログラムでは日本語の男性の声としてMicrosoft Ichiro が使われた。
プログラムを含むPowerPointファイル
スライドのノートを音声合成エンジンで読み上げたものをスライドに埋め込むことをすべてのスライドで行うVBAを利用したプログラムの例を示す。
VBAを利用しているのでマクロ実行を有効にしないと動作しない。
スライドショーを実行して最初のスライドにある「音声ファイルの作成・挿入」ボタンを押すと、読み上げた音声ファイルが埋め込まれる。
音声ファイルを一括して削除したい場合には、スライドショーを実行して、最初のスライドにある「音声ファイルの削除」ボタンを押す。
作成したPowerPointファイルをスライドショーにして、クリックなどでスライドを変えた場合に自動的に音声ファイルの再生を行うようにすると速く読み進めるのの邪魔になるので、例では、スライドの左上の再生ボタンを押さないと音声は出ないようにした。
VBAプログラム
「音声ファイルの作成・挿入」ボタンは、オブジェクト名 AddAudioFilesButton とした。スライドショーなどでボタンをクリックすると AddAudioFilesButton_Click() が呼び出される。そこから AddAudioFiles() が呼び出されて処理が進む。
「音声ファイルの削除」ボタンは、オブジェクト名 RemoveAudioFilesButton とした。スライドショーなどでボタンをクリックすると RemoveAudioFilesButton_Click() が呼び出される。そこから、RemoveAudioFiles() が呼び出されて処理が進む。
|
1 2 3 4 5 6 7 |
Private Sub AddAudioFilesButton_Click() Call AddAudioFiles End Sub Private Sub RemoveAudioFilesButton_Click() Call RemoveAudioFiles End Sub |
音声ファイルの作成・挿入
GetTtsEngine()で、指定された言語と性別の音声を合成できるText-To-Speech エンジンを取得する。
スライドを順番にみていき、ノート部分をMakeSpeechText() で必要に応じて編集して、MakeFileName()で音声ファイル名を生成し、Speak()で発生して、音声ファイルに保存する。
InsertAudio()で作成した音声ファイルをスライドに追加する。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
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は、テキストとスライド番号から発話用のテキストをつくる。スライド番号を使用している箇所はコメントアウトされていて使われていない。音声ファイルが正しくスライド番号と対応しているかをスライド番号を最初に読み上げることで確認する際に使用した。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 |
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で指定の音声ファイルをスライドに追加する。
スライドが切り替わった際に音声ファイルが自動的に再生されるようした場合も試してみたが、利用形態に合わないと思われるのでコメントアウトしている。音声の自動再生を有効にする場合には、再生ボタンがスライドショーの時に見えないようにしても良い。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 |
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 |
音声ファイルの削除
スライドを順番にみていき、サウンドファイルがあったら削除する。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 |
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 |
コメント
薫染庵様
先ほどお送りしましたコメントは、改行コードが無視されているため、段落が連なった長文となってしまいました。改行コードの入れ方が分からないので、段落間に全角のスペースを入れた文を、以下に再送いたします。
薫染庵様
初めまして。
貴サイトのプログラムを基に、図形のグループ化とアニメーション設定、ノート読み上げ、wavファイル埋め込みとアニメーション設定をワンクリックでできるマクロを作ることができました。これらの一連の操作に多くの時間を取られていたために（胃が少しおかしくなりかけていたために）、必要に迫られて貴プログラムを核にして、改変を進めてまいりました。お陰様で、講義資料のコンテンツ造りに専念できる環境を得ることができました。貴重なプログラムの公開をありがとうございました。
つきましては、拙プログラムの公開サイトで貴サイトとのリンクを張らせていただきたくお願い申し上げます。また、貴プログラムをコピー・改変させていただいた箇所にはその旨と貴サイトのURLを記させていただいております。もし、差支えがありましたら、お手数をおかけして申し訳ございませんが、ご返信いただけましたら幸いです。
拙プログラムの開発は、貴プログラムをはじめとしてネット上の様々なサイトのプログラムサンプルのお陰で進めることができました。オブジェクト指向のVBAもYouTubeで勉強しながらの心もとないレベルですが、多少は恩返しができるかなと思い、拙プログラムを公開する次第です。よろしく、ご高配のほどお願い申し上げます。
古橋武様
このサイトのプログラムが多少なりとも参考になったとすればうれしく思います。
リンクは自由に張っていただいて構いません。リンクは許諾不要と考えております。
また、役に立つプログラムを公開いただきありがとうございます (http://www.mybook-pub-site.sakura.ne.jp/Macro_for_Note_Reading/)。Microsoftの日本語の音声合成の質はいま一つなので、他の音声合成エンジンが使えるとプレゼンテーションなどの質の向上につながると思います。