６ パワーポイント動画作成 音声の改善
最終版履歴『１ パワーポイント動画作成（アニメーションとナレーション入り）』最終版『パワーポイント ビデオ作製 音声の改善』生徒に便利なように次の操作をしているパワーポイントのノートを音声合成でスライドに自動挿入しているこのスライドを…ameblo.jp『２ パワーポイントのノートをpythonで取得する』最終版『パワーポイント ビデオ作製 音声の改善』生徒に便利なように次の操作をしているパワーポイントのノートを音声合成でスライドに自動挿入しているこのスライドを…ameblo.jp『３ パワーポイント動画作成（アニメーションとナレーション入り）』最終版『パワーポイント ビデオ作製 音声の改善』生徒に便利なように次の操作をしているパワーポイントのノートを音声合成でスライドに自動挿入しているこのスライドを…ameblo.jp『４ パワーポイント動画作成（アニメーションとナレーション入り）』最終版『パワーポイント ビデオ作製 音声の改善』生徒に便利なように次の操作をしているパワーポイントのノートを音声合成でスライドに自動挿入しているこのスライドを…ameblo.jp『５ パワーポイント動画作成（アニメーションとナレーション入り）』最終版『パワーポイント ビデオ作製 音声の改善』生徒に便利なように次の操作をしているパワーポイントのノートを音声合成でスライドに自動挿入しているこのスライドを…ameblo.jp生徒に便利なように次の操作をしているパワーポイントのノートを音声合成でスライドに自動挿入しているこのスライドをビデオに変換すると、いつでもプレゼンを見られるしかし、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 LongPtrDim myHwnd As LongPtrDeclare PtrSafe Function SetForegroundWindow Lib "User32" (ByVal hWnd As LongLong) As LongPrivate Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)Dim s(99) As IntegerDim wavePath As StringType amimateShape pos As Integer name As StringEnd 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) 'アニメーション順序設定 NextActivePresentation.CreateVideo (getFileName() & ".mp4") MsgBox "完了"End SubFunction 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 = flgEnd 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 IfEnd 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 sldEnd 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
