６　パワーポイント動画作成　音声の改善

最終版

 

履歴

 

 

 

 

 

 

 

生徒に便利なように次の操作をしている
パワーポイントのノートを音声合成でスライドに自動挿入している
このスライドをビデオに変換すると、いつでもプレゼンを見られる

しかし、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