アニメーションへの対応：PowerPointをメディア講義に対応させるメモ（PPT+CeVIO）

前回の続きです．
PPTのノートに書かれたテキストを.wavに音声合成することは概ねうまく行ったのだが，各スライドJPEGと音声で動画を作成し，まとめて一つの動画にする．
一見問題ないようだが，スライド内にアニメーションなどがあった場合をどうするか，という問題に出くわした．
私の講義スライドもいくつかアニメーションで行っているスライドがあった（そんなに多くはないのだが）
ということで，ちょっと改変してこんな感じに

- ノートに書かれたテキストを「CeVIO:タカハシくん」で音声合成，ファイル保存
- スライドに音声へのリンクを作成，自動再生に設定
- 「スライドショーの記録」にてタイミングやアニメーションなどを動かす
    - 音声の長さを取得して「自動的に切り替え」の時間を設定
- MP4に書き出し

として動画作成を行うことにした．
こちらはPPT VBA のみで完結している(ffmpegは未使用)
前回と重複しているCodeもあるがとりあえず転記．
ちなみに私はタカハシくんを普通:1.00，元気:0.50 にて読ませています．
だいぶ仕様が煮詰まってきましたので，ユーザーフォームを呼び出して各種設定させた後に動作させています．
また，音声埋め込みが邪魔になる場合も考えて，音声への全リンク削除も独立して用意しています．
一部微妙なCodeがありますが，メディア講義資料を作成した後にCodeは整理します．

```vb:ノートを音声合成（CeVIOタカハシ）と保存をして，各スライドへリンク.bas
'ノートになにか記載されているスライドのみ音声出力
'コメントなしでも音声出力するには”スペース”を入れてください
Sub ノート音声合成埋込とスライド自動切替設定()
Dim folName As String
'PPTファイル名フォルダを作成する
With UserForm1
    .Caption = Left(ActivePresentation.name, InStrRev(ActivePresentation.name, Chr(46)) - 1)
    .Show
End With

End Sub

Sub ノート音声合成埋込解除()
    Dim sld As Slide
    'WAV保存
    For Each sld In ActivePresentation.Slides
        '非表示スライドは除外する
        If sld.SlideShowTransition.Hidden = msoFalse Then
            Call deleteWav(sld) '音声ファイル埋め込みを全て削除
        End If
    Next sld

End Sub

Function Main_Procedure()

Dim sld As Slide
Dim saveDir As String, folName As String
Dim r As Boolean
Dim sapi As Object
Dim wavFile As String

'ユーザーフォームの受け渡し
With UserForm1
    folName = .Caption
    Set sapi = SetSAPI(.SelectSAPI.ListIndex, .SpeedBox.Value, .VolumeBox.Value) ' SAPI5一覧から選択
    saveDir = .FolderBox.text
End With

'PPTファイル名フォルダを作成する
'FileExists関数を使用
'FileSystemObjectを利用 VBA画面のツールメニュー→参照設定で、Microsoft Scripting Runtimeにチェックを付ける必要がある
With CreateObject("Scripting.FileSystemObject")
    
    If saveDir = "" Then Exit Function 'キャンセル処理
    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
            wavFile = NarationWAV(sapi, sld.SlideNumber, saveDir) 'wav audio 作成
            If wavFile <> "" Then  ' なぜかwavFile が ""でかえってくる時がある
                Call deleteWav(sld) '音声ファイル埋め込みを全て削除
                Call appendWav(sld, wavFile) '音声ファイル埋め込み
                Call audioLength(sld, wavFile) 'スライド表示時間をWAVファイルの長さ+1sに変更 秒数は打ち切りされている
            End If
        End If
    Next sld
End With

End Function

'WAVファイルの長さを取得してスライド表示時間を変更
Function audioLength(ByRef sld As Slide, wavFile As String, Optional addSec As Integer = 1, Optional Pos As Integer = 27) As Variant
Dim FS As Object, wFile As Object, wFolder As Object
Dim wavDir As Variant

Set FS = CreateObject("Scripting.FileSystemObject")
wavDir = FS.GetParentFolderName(wavFile)
With CreateObject("Shell.Application").Namespace(wavDir)
    audioLength = .GetDetailsOf(.ParseName(FS.GetFileName(wavFile)), Pos)
End With
'スライド表示時間は wave時間＋addSec(default:1s)
sldTime = Minute(audioLength) * 60 + Second(audioLength) + addSec
'MsgBox sldTime
With sld.SlideShowTransition
    .AdvanceOnTime = msoTrue
    .AdvanceTime = sldTime
End With

End Function


'スライドにWAVを追加，自動再生設定
Function appendWav(ByRef sld As Slide, ByVal wavPath As String)
    With sld.Shapes.AddMediaObject2(wavPath).AnimationSettings
        .AdvanceMode = ppAdvanceOnTime 'スライドの切り替え　ppAdvanceOnTime=自動切替
        .AdvanceTime = 0 '指定した図形のアニメーションが実行されるまでの時間[s]
        .Animate = msoTrue 'スライドショー中のアニメーションを実行するかどうか
        .PlaySettings.PlayOnEntry = msoTrue 'アニメーション実行時、指定したビデオやサウンドを自動再生するか
        .PlaySettings.HideWhileNotPlaying = msoTrue 'スライドショー中に音声アイコンを隠す
    End With

End Function

'スライド内のWAVを全削除
Function deleteWav(ByRef sld As Slide)
    For n = sld.Shapes.Count To 1 Step -1 '最後からチェックしないとループ内の変数が変なことになる
        If sld.Shapes(n).Type = msoMedia Then
            If sld.Shapes(n).MediaType = ppMediaTypeSound Then '音声shapeの場合
                'MsgBox str(n) & "   " & sld.Shapes(n).name
                sld.Shapes(n).Delete
            End If
        End If
    Next n

End Function

'ノートを読み上げて音声ファイルにする
Function NarationWAV(sapi As Object, page As Integer, Dir As String) 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 wavName As String
wavName = Left(strNote, Length)
wavName = readableStr(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)
NarationWAV = wavName
End Function


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

Const SAFT48kHz16BitMono = 38
Const SSFMCreateForWrite = 3

Dim SpFS, SpVo
Set SpVo = sapi 'コピー

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

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

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

End Function

'name で指定した音声をセット
Function SetSAPI(num As Integer, Speed As Integer, volume As Integer) As Object

Set SetSAPI = CreateObject("SAPI.SpVoice")
SetSAPI.Rate = Speed '速さ -10 to 10
SetSAPI.volume = volume '大きさ 0 to 100

' インストールされている音声合成エンジンから num を選択
Set SetSAPI.Voice = SetSAPI.GetVoices.Item(num)

End Function


'読めない文字や記号を削除
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

```

```vb:ユーザーフォーム.frm
Private Sub OK_Buttion_Click()
UserForm1.Hide
Call Main_Procedure
End Sub

Private Sub SelectFolder_Click()
'  Dim folderPath As Variant
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = 0 Then
        'MsgBox "キャンセルボタンをクリックしました。"
            Exit Sub
        End If
    FolderBox.text = .SelectedItems(1)
    End With
End Sub

Private Sub SpeedBox_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    '数値以外は受け付けない
    If Chr(KeyAscii) < "0" Or Chr(KeyAscii) > "9" Then
        KeyAscii = 0
    End If
    '入力範囲のチェック
    If SpeedBox.Value < -10 Then
        SpeedBox.Value = -10
        Me!SpeedBox.SetFocus
    ElseIf SpeedBox.Value > 10 Then
        SpeedBox.Value = 10
        Me!SpeedBox.SetFocus
    End If

End Sub

Private Sub VolumeBox_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    '数値以外は受け付けない
    If Chr(KeyAscii) < "0" Or Chr(KeyAscii) > "9" Then
        KeyAscii = 0
    End If
    '入力範囲のチェック
    If VolumeBox.Value < 0 Then
        VolumeBox.Value = 0
        Me!VolumeBox.SetFocus
    ElseIf VolumeBox.Value > 100 Then
        VolumeBox.Value = 100
        Me!VolumeBox.SetFocus
    End If

End Sub

Private Sub UserForm_Initialize()
    'SAPIの一覧をコンボボックスに登録　初期値0
    Dim n As Integer
    With CreateObject("SAPI.SpVoice").GetVoices
        For n = 0 To .Count - 1
            UserForm1.SelectSAPI.AddItem (str(n) & ": " & .Item(n).GetDescription)
        Next n
    End With
    UserForm1.SelectSAPI.ListIndex = 0
    
    'SpeedのIMEModeを指定
    SpeedBox.IMEMode = 3
    
    '保存フォルダパスの初期値
    'FolderBox.text = CurDir
    FolderBox.text = Application.ActivePresentation.Path
 
   
End Sub
```