最終版
履歴
生徒に便利なように次の操作をしている
パワーポイントのノートを音声合成でスライドに自動挿入している
このスライドをビデオに変換すると、いつでもプレゼンを見られる
しかし、windows標準SAPIではハルカの音声がどうも流暢ではない
voicevoxを導入すると流暢な音声が使えます。
下記の手順でハルカから違う音声に変更できます
- voicevoxのインストール https://voicevox.hiroshiba.jp/
- SAPIForVOICEVOXのインストール https://github.com/shigobu/SAPIForVOICEVOX/releases
- コントロールパネル・音声認識・音声合成で音声の選択をする
- voicevoxを起動しておく
パワーポイントでマクロを実行します。指定された音声でノートが組み込まれビデオが作成されます
波音リツノーマルに替えて、とても流暢な音声です
コードは
Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Dim myHwnd As LongPtr
Declare PtrSafe Function SetForegroundWindow Lib "User32" (ByVal hWnd As LongLong) As Long
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Dim s(99) As Integer
Dim wavePath As String
Type amimateShape
pos As Integer
name As String
End Type
'
'
'
Sub start()
Dim cd As String
cd = ActivePresentation.Path
wavePath = cd & "\voice.wav" ' PowerPointファイルがあるのと同フォルダに、wavファイルを作成
Call getNoteandCreateWAV 'WAV作成、貼り付け
Dim sld As Slide
For Each sld In ActivePresentation.Slides
r = reOrderAminateShape(sld.SlideNumber) 'アニメーション順序設定
Next
ActivePresentation.CreateVideo (getFileName() & ".mp4")
MsgBox "完了"
End Sub
Function getFileName()
fn = Application.ActivePresentation.FullName
p = InStr(fn, ".pptm") + InStr(fn, ".pptx")
getFileName = Mid(fn, 1, p - 1)
End Function
'アニメーションの順番変更 既存シェイプにWAVを位置づける
Function reOrderAminateShape(sid)
Dim amedia(99) As amimateShape
Dim ashape(99) As amimateShape
' アニメーション ActivePresentation.Slides(sid).Shapes(k).AnimationSettings.Animate=-1
' 名前 ActivePresentation.Slides(sid).Shapes(k).Name
'type
'msoAutoShape 1 AutoShape
'msoCallout 2 吹き出し
'msoMedia 16 メディア
'msoGroup 6 Group
'msoPicture 13 画像
'アニメーションシェイプの取得と分類
n = ActivePresentation.Slides(sid).Shapes.Count
n1 = 1
n2 = 1
For k = 1 To n
If ActivePresentation.Slides(sid).Shapes(k).AnimationSettings.Animate = -1 Then 'アニメーションシェイプ
If ActivePresentation.Slides(sid).Shapes(k).Type = 16 Then 'メディア
amedia(n1).pos = k
amedia(n1).name = k
n1 = n1 + 1
Else 'その他
ashape(n2).pos = k
ashape(n2).name = k
n2 = n2 + 1
End If
' Debug.Print k & " " & ActivePresentation.Slides(sid).Shapes(k).type & " "; ActivePresentation.Slides(sid).Shapes(k).name
End If
Next
n1 = n1 - 1
n2 = n2 - 1
flg = 0
If n2 > (n1 - 1) Then flg = -1 'シェイプとノートの数が一致しているか？
If flg = 0 Then
Call setAnimationOrder(sid, 0, amedia(1).pos, False) '最初のノートWAVを先頭に
n = 2
For k = 1 To n2
Call setAnimationOrder(sid, n, ashape(k).pos, False) '既存シェイプ
Call setAnimationOrder(sid, n + 1, amedia(k + 1).pos, True) '既存シェイプの後にＷＡＶを
n = n + 2
Next
Else
' Set myDocument = ActivePresentation.Slides(sid) 'エラーメッセージを表示
' myDocument.Shapes.AddTextbox(Type:=msoTextOrientationHorizontal, _
' Left:=100, Top:=100, Width:=200, Height:=50).TextFrame _
' .TextRange.Text = "シェイプとノートの数が不一致"
End If
reOrderAminateShape = flg
End Function
'アニメーション順序
Sub setAnimationOrder(sid, sorder, shp, cond)
ActivePresentation.Slides(sid).Shapes(shp).AnimationSettings.AnimationOrder = sorder '順番
If cond = True Then '
With ActivePresentation.Slides(sid).Shapes(shp).AnimationSettings
.AdvanceMode = ppAdvanceOnTime '直前の動作の後
.AdvanceTime = 0
.Animate = True
End With
End If
End Sub
'WAVを貼り付ける
Sub SlideVoice(sid, fn)
Dim i As Long
Dim cd As String
cd = ActivePresentation.Path
Dim oSlide As Slide
Dim oShp As Shape
dx = 50
wTop = 50
wleft = 0
FileName = wavePath
wleft = wleft + s(sid) * dx
s(sid) = s(sid) + 1
Set oSlide = ActivePresentation.Slides(sid)
Set oShp = oSlide.Shapes.AddMediaObject2(FileName, False, True, wleft, wTop) 'ＷＡＶ貼り付け
With oShp.AnimationSettings.PlaySettings
.PlayOnEntry = True
.HideWhileNotPlaying = False
End With
Kill wavePath '削除
End Sub
'ノートを取得して、1行ごとに音声ファイルを作成する
Sub getNoteandCreateWAV()
Dim sld As Slide
For Each sld In ActivePresentation.Slides
Dim shp As Shape
Set shp = sld.NotesPage.Shapes.Placeholders(2) 'noteを取得
w = shp.TextFrame.TextRange.Text
w2 = Split(w, vbCr) 'noteを行に分割
sidn = sld.SlideNumber
n = 0
For k = 0 To UBound(w2)
fn = wavePath
wline = w2(k)
Call createwav(fn, wline) '文字を送りWAVファイルを作成する
Call SlideVoice(sidn, fn) 'WAVを貼り付ける
n = n + 1
Next
Next sld
End Sub
Function createwav(fn, word)
Const SAFT48kHz16BitStereo = 39
Const SSFMCreateForWrite = 3
Dim oFileStream, oVoice
Dim oSlide As Slide
Dim fso As Object
Set oFileStream = CreateObject("SAPI.SpFileStream") ' wavファイルに保存
oFileStream.Format.Type = SAFT48kHz16BitStereo '音声フォーマット
oFileStream.Open wavePath, SSFMCreateForWrite '書き込みモード
Set oVoice = CreateObject("SAPI.SpVoice") '音声合成
Set oVoice.AudioOutputStream = oFileStream '音声の出力先をファイルへ
oVoice.Speak word 'ノートを話す
oFileStream.Close 'ファイルをクローズ
End Function