Sub EmbedVoice()

    ' 現在のスライド番号を取得
    Dim n As Long
    n = ActiveWindow.Selection.SlideRange.SlideIndex

    ' 現在のスライドのノートを取得
    Dim strNote As String
    strNote = ActivePresentation.Slides(n).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Text

    ' ノートが空白なら終了
    If strNote = "" Then
        Exit Sub
    End If

    ' 現在のフォルダを取得
    Dim cd As String
    cd = ActivePresentation.Path

    ' wavファイルのパスを作成
    Dim wavePath As String
    wavePath = cd & "\voice.wav"

    ' wavファイルが既にあれば削除
    ' 下の SSFMCreateForWrite = 3 で上書きできるはずだけど何故かできないので
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(wavePath) Then Kill wavePath

    ' wavファイルに保存
    Const SAFT48kHz16BitStereo = 39
    Const SSFMCreateForWrite = 3

    Dim oFileStream, oVoice

    Set oFileStream = CreateObject("SAPI.SpFileStream")
    oFileStream.Format.Type = SAFT48kHz16BitStereo
    oFileStream.Open wavePath, SSFMCreateForWrite

    Set oVoice = CreateObject("SAPI.SpVoice")
    Set oVoice.AudioOutputStream = oFileStream
    oVoice.Speak strNote

    oFileStream.Close

    ' audioオブジェクトの埋め込み
    Dim oSlide As Slide
    Dim oShp As Shape
    Dim oEffect As Effect

    Set oSlide = ActivePresentation.Slides(n)

    Set oShp = oSlide.Shapes.AddMediaObject2(wavePath, False, True, 10, 10)

    With oShp.AnimationSettings.PlaySettings
        .HideWhileNotPlaying = True
    End With

    MsgBox "Done."

End Sub