掲載のCodeは色々問題もありそうなので参考程度にしてくださいね．

目的

メディア講義に使用するスライドショーにナレーションを付加した動画を作成しよう．

経緯

新型コロナウィルスの拡大に伴い，私の所属する大学では4月よりメディア講義を行うことになった．まあ，私の担当講義は5月から始まる（4月は別任務で多忙を極める）のでとりあえず被害は少ないほうだろう．ちなみにメディア講義に決定したのは3月も残すところあと3日程度のある日だった，いやマジかって感じですね．
メディア講義にも色々選択肢があり，私は当初ZOOMを使用した遠隔講義を想定していたのだが，残念なことに講義室が対応しておらず早々に断念．他の先生方（4月からメディア講義に対応しなければいけない方々）の動向をうかがうと，どうやら

PPT プレゼンテーション
- 音声吹き込みでナレーション > MP4形式にて保存 > uploadして学生が聴講

のようだ．音声吹き込みが一番の問題で，間違うと訂正が面倒なのは明らかだ．
いや，一発OKでも90分でしょ．各セクションに分けて間違いを訂正しながら進めていくと．．．．いつになったら終わるんだろうか．何より自分の音声を聞きながら修正していく作業は苦痛でしかない．
というわけで幸運にも準備期間がある私は下記のごとく準備をすすめることに決めた．
もしかしたら私の授業の頃には新型コロナウィルスが収束して対面講義OKとなっていることを考慮しながら．．．

実際の作業

ノートにナレーション原稿を入力

これは根気強くやるしかないですね．こんなことならAmiVoice買っときゃよかった．
今年度の教育経費で買おうかなと悩み中

各スライドを音声合成

~~いつの間にか（2010年頃？）Windowsにいる「Haruka Desktop」に喋ってもらいます．~~
いろいろなソフト（VOICEROIDやらAITalkやら）もかなりの時間を費やして検討したのだが，個人利用前提となると今回の目的では使用しにくいし，商用OKとなると高価すぎて手が出せませんでした．

2020.04.13
そんな矢先に CeVIO Creative Studio がメディア講義のために無償提供するというニュースが舞い込んできた．
このような対応，嬉しいですね．早速使ってみようと申請書をDLしたんですが，これ，大学の公印が必要やんか．
いやいやいや，公印をもらう行為が面倒すぎます．「ac.jpのアドレスでOK」としてくれれば最高なんだけどな
まあ，無償提供はさておき，この CeVIO Creative Studio の音声はいいですね．
というわけで，Haruka さんから タカハシ くんに変更して作成します．

作業簡略化のために「PPT VBA」にて**各スライド内のノートを音声合成し，音声を保存（.wav）**させよう．

ノートをナレーション音声にするマクロを作成

PPT の標準モジュールにコピペして使用してくださいね

プレゼンテーションの各ノートを音声ファイルに出力.bas


'ノートになにか記載されているスライドのみ音声出力
'コメントなしでも音声出力するには”スペース”を入れてください


Sub プレゼンテーションの各ノートを音声ファイルに出力()

Dim sld As Slide
Dim saveDir As String
Dim r As Boolean
Dim sapi As Object
   
'PPTファイル名フォルダを作成する
folName = Left(ActivePresentation.name, InStrRev(ActivePresentation.name, Chr(46)) - 1)
' SAPI5一覧から選択
Set sapi = SetSAPI("タカハシ", -1, 75) 
    
'FileExists関数を使用
'FileSystemObjectを利用 VBA画面のツールメニュー→参照設定で、Microsoft Scripting Runtimeにチェックを付ける必要がある
With CreateObject("Scripting.FileSystemObject")
    
    saveDir = InputBox("SAVE Dir", "保存ディレクトリ", CurDir)
    If saveDir = "" Then Exit Sub 'キャンセル処理
    saveDir = .BuildPath(saveDir, folName & "＿音声合成") '保存フォルダ作成
    If .FolderExists(saveDir) Then
        '何もしない
        MsgBox saveDir & vbCrLf & "Folder exists!"
    Else
        MkDir saveDir
    End If
   
    saveDir = .BuildPath(saveDir, "audio")
    If .FolderExists(saveDir) Then
        '何もしない
    Else
        MkDir saveDir
    End If
   
    'WAV保存
    For Each sld In ActivePresentation.Slides
        '非表示スライドは除外する
        If sld.SlideShowTransition.Hidden = msoFalse Then
            Call NarationWAV(sapi, sld.SlideNumber, saveDir)
        End If
    Next sld
End With

End Sub

ノートテキストを音声合成.bas

'ノートを読み上げて音声ファイルにする
Function NarationWAV(sapi As Object, page As Integer, Dir As String)

Dim Length As Integer
Length = 20 'インデックス文字列の長さ

' ノートの文字列を取得
Dim strNote As String
strNote = ActivePresentation.Slides(page). _
          NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Text
          
' wav保存のためのフルパス作成
Dim wavName As String
wavName = Left(strNote, Length)
wavName = readableStr(wavName, "_")
'MsgBox (wavName)

'FileSystemObjectを利用 VBA画面のツールメニュー→参照設定で、Microsoft Scripting Runtimeにチェックを付ける必要がある
wavName = CreateObject("Scripting.FileSystemObject").BuildPath(Dir, Format(page, "000") & " - " & wavName & ".wav")
    
'ノート未記載（空）の場合はナレーション再生の必要なし
If strNote = "" Then
Exit Function
End If

'WAV出力
Call Text_to_Speech(sapi, strNote, wavName)

End Function

音声合成.bas

Function Text_to_Speech(sapi As Object, strNote As String, wavFile As String)

Const SAFT48kHz16BitStereo = 39
Const SSFMCreateForWrite = 3

Dim SpFS, SpVo

Set SpVo = sapi 'コピー

Set SpFS = CreateObject("SAPI.SpFileStream")
SpFS.Format.Type = SAFT48kHz16BitStereo
SpFS.Open wavFile, SSFMCreateForWrite

'FileStreamで再生する
Set SpVo.AudioOutputStream = SpFS
SpVo.Speak strNote

' 音声合成エンジンを開放
Set SpVo = Nothing
SpFS.Close

End Function

SAPI5を指定.bas

'name で指定した音声をセット
Function SetSAPI(name As String, speed As Integer, volume As Integer) As Object
'Dim Haruka_Set As Object
Set SetSAPI = CreateObject("SAPI.SpVoice")
SetSAPI.Rate = speed '速さ -10 to 10
SetSAPI.volume = volume '大きさ 0 to 100
SetSAPI.WaitUntilDone (1000) '最後の無音？[ms]

' インストールされている音声合成エンジンから name を選択
For n = 0 To SetSAPI.GetVoices.Count - 1
    If InStr(SetSAPI.GetVoices.Item(n).GetDescription, name) Then
    '    MsgBox (n)
        Set SetSAPI.Voice = SetSAPI.GetVoices.Item(n)
        Exit For
    End If
Next
' name がいない場合は中止
If InStr(SetSAPI.Voice.GetDescription, name) < 1 Then
    MsgBox name & "がインストールされていません" & vbCrLf & "現在の設定 : " & SetSAPI.Voice.GetDescription
Exit Function
End If

End Function

ファイル名に使えない文字を置換.bas

'読めない文字や記号を削除
Function readableStr(ByVal sourceStr As String, _
        Optional ByVal replaceChar As String = "") As String
   
    readableStr = sourceStr
    readableStr = Replace(readableStr, "\", replaceChar)
    readableStr = Replace(readableStr, "/", replaceChar)
    readableStr = Replace(readableStr, ":", replaceChar)
    readableStr = Replace(readableStr, "*", replaceChar)
    readableStr = Replace(readableStr, "?", replaceChar)
    readableStr = Replace(readableStr, """", replaceChar)
    readableStr = Replace(readableStr, "<", replaceChar)
    readableStr = Replace(readableStr, ">", replaceChar)
    readableStr = Replace(readableStr, "|", replaceChar)
    readableStr = Replace(readableStr, "[", replaceChar)
    readableStr = Replace(readableStr, "]", replaceChar)
    readableStr = Replace(readableStr, Chr(11), replaceChar)
    readableStr = Replace(readableStr, vbCr, replaceChar)

End Function

ついでにノートをHarukaさんに読んでもらうマクロも用意してみた．
PPTに読み上げ機能があるためあまり需要はないかな．
"Haruka"を"タカハシ"に置換すればCeVIO - タカハシ　君も利用可能

ノートを読み上げ.bas


Sub ノートをナレーション再生()

'ノートの文字列を取得
'現在表示のスライド番号：ActiveWindow.Selection.SlideRange.SlideIndex
Dim strNote As String
strNote = ActivePresentation.Slides(ActiveWindow.Selection.SlideRange.SlideIndex). _
          NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Text

'ノート未記載（空）の場合はナレーション再生の必要なし
If strNote = "" Then
Exit Sub
End If

' 音声合成エンジンをHarukaにセット
Dim SpVo As Object
Set SpVo = Haruka_Set()

' 音声合成実行
SpVo.Speak strNote

' 音声合成エンジンを開放
Set SpVo = Nothing

End Sub

'Harukaをセット
Function Haruka_Set() As Object
'Dim Haruka_Set As Object
Set Haruka_Set = CreateObject("SAPI.SpVoice")
Haruka_Set.Rate = -1 '速さ -10 to 10
Haruka_Set.Volume = 75 '大きさ 0 to 100

' インストールされている音声合成エンジンからHarukaを選択
For n = 0 To Haruka_Set.GetVoices.Count - 1
    If InStr(Haruka_Set.GetVoices.Item(n).GetDescription, "Haruka") Then
    '    MsgBox (n)
        Set Haruka_Set.Voice = Haruka_Set.GetVoices.Item(n)
        Exit For
    End If
Next
' Haruka がいない場合は中止
If InStr(Haruka_Set.Voice.GetDescription, "Haruka") < 1 Then
    MsgBox "Harukaがインストールされていません" & vbCrLf & "現在の設定 : " & Haruka_Set.Voice.GetDescription
Exit Function
End If

End Function

各スライドをJPEG保存

名前を付けて保存，から保存すると「スライド○.JPG」（なぜJPGは大文字なのだろうか）になるのでその後の合成作業に都合が悪い．
というわけで音声ファイルと同じ名前でJPEG保存をするマクロを作成した

スライドをJPEGに.bas

Sub プレゼンテーションの各スライドをJPEG出力()

Dim sld As Slide
Dim saveDir As String
Dim r As Boolean
Dim sapi As Object
   
'PPTファイル名フォルダを作成する
folName = Left(ActivePresentation.name, InStrRev(ActivePresentation.name, Chr(46)) - 1)
   
'FileExists関数を使用
'FileSystemObjectを利用 VBA画面のツールメニュー→参照設定で、Microsoft Scripting Runtimeにチェックを付ける必要がある
With CreateObject("Scripting.FileSystemObject")
    saveDir = InputBox("SAVE Dir", "保存ディレクトリ", CurDir)
    If saveDir = "" Then Exit Sub 'キャンセル処理
    saveDir = .BuildPath(saveDir, folName & "＿音声合成") '保存フォルダ作成
    If .FolderExists(saveDir) Then
        '何もしない
        MsgBox saveDir & vbCrLf & "Folder exists!"
    Else
        MkDir saveDir
    End If
   
    saveDir = .BuildPath(saveDir, "image")
    If .FolderExists(saveDir) Then
        '何もしない
    Else
        MkDir saveDir
    End If
   
    'JPEG保存
    For Each sld In ActivePresentation.Slides
        '非表示スライドは除外する
        If sld.SlideShowTransition.Hidden = msoFalse Then
            Call SaveJPEG(sld.SlideNumber, saveDir)
        End If
    Next sld
End With

End Sub

JPEG保存

'JPEG保存
Function SaveJPEG(page As Integer, Dir As String)

Dim Length As Integer
Length = 20 'インデックス文字列の長さ

' ノートの文字列を取得
Dim strNote As String
'n = ActiveWindow.Selection.SlideRange.SlideIndex
strNote = ActivePresentation.Slides(page). _
          NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Text
          
' wav保存のためのフルパス作成
Dim jpgName As String
jpgName = Left(strNote, Length)
jpgName = readableStr(jpgName, "_")

'FileSystemObjectを利用 VBA画面のツールメニュー→参照設定で、Microsoft Scripting Runtimeにチェックを付ける必要がある
jpgName = CreateObject("Scripting.FileSystemObject").BuildPath(Dir, Format(page, "000") & " - " & jpgName & ".jpg")
    
'ノート未記載（空）の場合はナレーション再生の必要なし
If strNote = "" Then
Exit Function
End If

'JPEG出力
  With ActivePresentation.Slides(page)
    .Export _
        fileName:=jpgName, _
        FilterName:="jpg"
  End With

End Function

各音声とスライドのペアからMP4作成

ffmpegにてbatcv処理させる．ffmpegはこちらからDL ffmpeg．
ffmpegはbatchファイルと同じフォルダに置く．また，

audio: マクロで作成した音声ファイル(.wav)を格納
image: マクロで作成した画像ファイル(.jpg)を格納

JPEGファイルと音声ファイルの接頭3桁の番号の一致でMP4を作成していく．バッジファイルの制約が大嫌いです，面倒だなぁ．

音声とスライドを合成.bat



@echo off
rem 	変数の代入をただちに実行するおまじない
setlocal ENABLEDELAYEDEXPANSION

set audio_dir="./audio/"
md %audio_dir%
set image_dir="./image/"
md %image_dir%
set mpeg_dir="./mpeg/"
md %mpeg_dir%
set curr_dir=./
rem 予め muon.wav を準備しておく
set muon=%curr_dir%muon.wav
echo %muon%
rem 最低のファイル長さ比較
set ext=wav

for %%F in ("!audio_dir!"*.wav) do (
	rem ファイル名
	set filename=%%F
	echo !filename!----------------------------------------
	rem 音声ファイル名
	set audiofile=!audio_dir!!filename!
	set note=!filename:~8,3!
	rem echo !note!
	rem echo !ext!
	
	rem mpegファイルが作成されていないときのみmpegファイルを作成
	if exist "!mpeg_dir!!filename:~0,-4!".mp4 (
		rem 処理済み
		echo !mpeg_dir!!filename:~0,-4!.mp4 は存在します!
	) else (
		rem muon作成＆使用 3sで5秒が作成されるようだ
		if !note!==!ext! (
			ffmpeg -y -i "!audiofile!" -af "apad=pad_dur=3" -c:v copy "!muon!"
			set audiofile=!muon!
			echo !audiofile!作成
		)
		
		rem ffmpegで静止画＋音声のmp4を作成
		rem echo !audiofile!-------------
		ffmpeg -loop 1 -i "%image_dir%!filename:~0,-4!".jpg -i "!audiofile!" -af "adelay=2s|2s" -vcodec libx264 -acodec aac -strict experimental -ab 320k -ac 2 -ar 48000 -pix_fmt yuv420p -shortest "%mpeg_dir%!filename:~0,-4!".mp4
		echo %mpeg_dir%!filename:~0,-4!.mp4 変換完了
	)
)

rem muon.wav の削除
rem if exist "%muon%" (
rem 	del %muon%
rem	echo %muon%を削除しました
rem )

pause

pause

各スライドのMP4全結合

最初はffmpegで一気に処理しようと思っていたのだが，思いのほか結合箇所の映像・音声が乱れてしまうことがわかった．
いろいろ悩んだ挙げ句に**Windowsフォト（Win10標準）が扱いやすく，何より追加費用がかからない．プログラミングとは離れるが使用方法のみ掲載

先頭の動画を右クリック -> プログラムから開く -> フォト
右上の「編集と作成」-> テキスト入りビデオの作成 -> 先頭以外の動画をD&D，ストーリーボードに配置 -> 右上の「ビデオの完了」で保存します．
再生速度などはお好きにどうぞ．

これで動画が完成するでしょう．
さて，あとはひたすらナレーション原稿の作成だ，鬱鬱鬱．