Excel VBA 短い台詞から.wavファイル機械音声を作成してみた

Excelで入力された文字列(台詞)からwavファイルを作成してみた。
機械音声のファイルを作成してみました。
意外と簡単に音声ファイル .wavを作ることができそうなので、
コードをアレンジしながら使ってみてください。
何か面白い使い方、アイデアがあったら(視聴者の皆さんがひらめいたら)
コメント欄やメッセージで教えてくださいね。
#ExcelVBA #音声ファイル #機械音声

下記、いつものあのあのそのその解説動画です
youtu.be
https://youtu.be/oQgYWk4gKYk
目次
00:00 0.あいさつ
00:34 1.音声ファイル作成のコードを修正
02:30 2.Excelのシートに台詞を書き、テストする
05:43 3.シートをコピーして使ってみる
08:32 4.蛇足で全ての台詞をまとめたファイルを作ってみた

0.あいさつ
最近、パワーポイントで機械音声のナレーションを使っていた
視聴者さまよりエクセルで音声ファイルを作成できないか？と質問が来たので、チャレンジしてみた。
Win10 64ビット Office365 Excel 64ビットでテストしました。

1.音声ファイル作成のコードを修正
下記、パワーポイントのノートを音声変換するコードです。
これを切り取って、
Excelで台詞とファイル名を渡されたら、作成するように変更しました

Sub 埋め込み()

Dim n As Long                     '現在のスライド
Dim strNote As String             'ノート取得
Dim cd As String                  'フォルダを取得
Dim wavePath As String            'wavファイルを作成
Dim oFileStream, oVoice           'wavファイルに保存
Dim oSlide As Slide               '音声データ
Dim oShp As Shape

'現在のスライドのノートを取得
 n = ActiveWindow.Selection.SlideRange.SlideIndex
 
 strNote = ActivePresentation.Slides(n).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Text
 
'ノートが空白なら終了
If strNote = "" Then
    Exit Sub
End If

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

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

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

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オブジェクトの埋め込み(音声データを埋め込む)
Set oSlide = ActivePresentation.Slides.Item(n)

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

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

↑から、抜き出して
セリフ文字列と書き込みファイル名を受け取り
wavファイルを作成する

Sub 音声ファイル作成(strMOJI As String, wavePath As String)

    Dim oFileStream, oVoice           'wavファイルに保存
     
    '音声変換文字列が空白なら終了
    If strMOJI = "" Then
        Exit Sub
    End If
    
    'wavファイルに保存
    Const SAFT48kHz16BitStereo = 39
    Const SSFMCreateForWrite = 3
    
    Set oFileStream = CreateObject("SAPI.SpFileStream")
    oFileStream.Format.Type = SAFT48kHz16BitStereo
    oFileStream.Open wavePath, SSFMCreateForWrite
    
    Set oVoice = CreateObject("SAPI.SpVoice")
    Set oVoice.AudioOutputStream = oFileStream
    oVoice.Speak strMOJI   '台詞を渡す、話す？
    
    oFileStream.Close
    
    Set oFileStream = Nothing
    Set oVoice = Nothing

End Sub

2.Excelのシートに台詞を書き、テストする

シートのイメージ

C3にべースのファイル名を書き、
B列にNO 連番と言っても、自分で好きな番号をふり
D列に変換したい言葉、台詞を入力する

C列に出力先のファイル名を作成した。
=$C$3&TEXT(B6,"000")&TRIM(LEFT(D6,10))&".wav"

この表をループで回して、
機械音声の台詞ファイルを作成してみた。

Sub 台詞から音声ファイルを作る()

    Dim strFILENAME As String
    Dim n As Integer
    Dim str台詞 As String
    
    Dim r As Range
    
    Set r = Range("B5")  '表の左上、基準値の場所をセット
    
    For n = 1 To 999   '最大999まで、そんなにいらないか
        
        str台詞 = Trim(r.Offset(n, 2))
        If Len(str台詞) = 0 Then
            Exit For
        End If
        
        'ファイル名をマクロ実行位置\連番+台詞
        strFILENAME = ThisWorkbook.Path & "\" & r.Offset(n, 1)
    
        '音声ファイル作成 の サブルーチンを呼ぶ
        Debug.Print strFILENAME & " " & str台詞
        Call 音声ファイル作成(str台詞, strFILENAME)
    Next
    
    MsgBox "終了しました、ファイルを確認してね"

End Sub

3.シートをコピーして使ってみる
運用の例としては、シートをコピーして、管理するなど、使い方はいろいろと？
こんな感じで音声ファイルとして作成可能なので、使ってみてください。
何に？使うんだよ・・・

4.蛇足で全ての台詞をまとめたファイルを作ってみた
なんか、無計画で作成したので、
ファイル名の作り方とか・・・変だったけど、
下記、動画の最後、思い付きで追加したコードです。

Sub 台詞から音声ファイルを作る()

    Dim strFILENAME As String
    Dim n As Integer
    Dim str台詞 As String
    Dim strALL As String
    
    Dim r As Range
    
    Set r = Range("B5")  '表の左上、基準値の場所をセット
    strALL = "" '初期化
    For n = 1 To 999   '最大999まで、そんなにいらないか
        
        str台詞 = Trim(r.Offset(n, 2))
        If Len(str台詞) = 0 Then
            Exit For
        End If
        strALL = strALL & str台詞
        
        'ファイル名をマクロ実行位置\連番+台詞
        strFILENAME = ThisWorkbook.Path & "\" & r.Offset(n, 1)
    
        '音声ファイル作成 の サブルーチンを呼ぶ
        Debug.Print strFILENAME & " " & str台詞
        Call 音声ファイル作成(str台詞, strFILENAME)
    Next
    
    'ループを抜けたら、すべてを作る
    'ファイル名をマクロ実行位置\C3&全て.wav
    strFILENAME = ThisWorkbook.Path & "\" & Range("c3") & "全て.wav"

    '音声ファイル作成 の サブルーチンを呼ぶ
    Call 音声ファイル作成(strALL, strFILENAME)
    
    
    MsgBox "終了しました、ファイルを確認してね"

End Sub