powerpointのノートを音声合成して貼り付け、動画を作成する

2023/11/4改訂

『パワーポイント　ビデオ作製　音声の改善』

powerpointをプレゼンをするのですが、あとで再利用したいです

• ノートにプレゼンで話すことを記述します
• ノートをwindows標準の音声合成でWAVにします
• WAVをスライドに貼り付けます
• powerpointで動画を作成します
• 作成した動画を公開します

これで再利用ができます

使うのはVBAとwindows標準機能のみです

マクロは以下です

'参照サイト　https://www.alta.co.jp/blog/post-1725/
Sub create()
    Call SlideVoice
    Call SaveVideo
    MsgBox "完了"
End Sub
Sub SaveVideo()
    ActivePresentation.CreateVideo (ActivePresentation.Path & "\test.mp4")
End Sub
Sub SlideVoice()
    Dim i As Long
    Dim cd As String
    Dim wavePath As String
    Const SAFT48kHz16BitStereo = 39
    Const SSFMCreateForWrite = 3
    Dim oFileStream, oVoice
    Dim oSlide As Slide
    Dim oShp As Shape
    Dim fso As Object
    Dim strNote As String
    cd = ActivePresentation.Path                                                                                ' PowerPointファイルのあるフォルダパスを取得
    wavePath = cd & "\voice.wav"                                                                                ' PowerPointファイルがあるのと同フォルダに、wavファイルを作成
    
    With ActivePresentation
        For i = 1 To .Slides.Count                                                                              'スライドの数だけ行う
            strNote = ActivePresentation.Slides(i).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Text    ' 現在のスライドのノートを取得
              
            If strNote <> "" Then                                                                               ' ノートが空白なら以下は実行しない
                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 strNote                                                                            'ノートを話す
                oFileStream.Close                                                                               'ファイルをクローズ
            
                Set oSlide = ActivePresentation.Slides(i)                                                       '現在のスライドを取得
                Set oShp = oSlide.Shapes.AddMediaObject2(wavePath, False, True, 10, 10)                         ' audioオブジェクトの埋め込み
                With oShp.AnimationSettings.PlaySettings                                                        'アニメーションの設定
                    .PlayOnEntry = True                                                                         '自動再生
                    .HideWhileNotPlaying = True                                                                 '再生時にのみ表示
                End With
                Set fso = CreateObject("Scripting.FileSystemObject")                                            'ファイル操作
                If fso.FileExists(wavePath) Then Kill wavePath                                                  ' 埋め込み終わったらwavファイルを消す
            End If
        Next i
    End With

    MsgBox "音声埋め込み完了"
End Sub