前回の続きです．
PPTのノートに書かれたテキストを.wavに音声合成することは概ねうまく行ったのだが，各スライドJPEGと音声で動画を作成し，まとめて一つの動画にする．
一見問題ないようだが，スライド内にアニメーションなどがあった場合をどうするか，という問題に出くわした．
私の講義スライドもいくつかアニメーションで行っているスライドがあった（そんなに多くはないのだが）
ということで，ちょっと改変してこんな感じに
- ノートに書かれたテキストを「CeVIO:タカハシくん」で音声合成，ファイル保存
- スライドに音声へのリンクを作成，自動再生に設定
- 「スライドショーの記録」にてタイミングやアニメーションなどを動かす
- 音声の長さを取得して「自動的に切り替え」の時間を設定
- MP4に書き出し
として動画作成を行うことにした．
こちらはPPT VBA のみで完結している(ffmpegは未使用)
前回と重複しているCodeもあるがとりあえず転記．
ちなみに私はタカハシくんを普通:1.00，元気:0.50 にて読ませています．
だいぶ仕様が煮詰まってきましたので，ユーザーフォームを呼び出して各種設定させた後に動作させています．
また，音声埋め込みが邪魔になる場合も考えて，音声への全リンク削除も独立して用意しています．
一部微妙なCodeがありますが，メディア講義資料を作成した後にCodeは整理します．
ノートを音声合成（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
ユーザーフォーム.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