前書き

むかしむかし、ゆっくりさんにPowerPointを使って喋らせた動画を作成したことがあります。

Powerpointを使用したゆっくり動画の作成 https://t.co/nCQIQI6p7M #sm18775987 #ニコニコ動画
— m.ita (@mima_ita) August 2, 2019

今回は、令和の時代になったので、ゆっくりさんには卒業してもらって、VOICEROIDE2の茜ちゃんにやっていただくこととします。

仕組み

PowerPointの各スライドのページに記載された文字をVOICEROIDE2を用いてWavファイルの作成を行います。その作成したWavファイルをスライドに埋め込みます。

スライドショーを実行することで、スライドを切り替え後、マウスクリックをすることで、茜ちゃんがしゃべってくれます。

使い方

環境:
Windows10
Office16 PowerPoint(32bit)
VOICEROIDE2

(1)以下から「akanechan.pptm」ファイルをダウンロードするか、任意のpptmファイルのVBAに「src」フォルダのclsとbasファイルをインポートしてください。
https://github.com/mima3/akanechan_powerpoint

(2)スライドのノートに喋らせたい文字を入力します。

(3) VOICEROID2を起動します。

(4)「AddSoftTalk」マクロを実行します。

これにより以下の処理が行われます。

すべてのスライドのノートに書かれた文字が、改行毎にVOICEROID2におくられてWavファイルを作成します。このファイルはPowerPointと同じフォルダに存在します。
作成したWavファイルを各スライドに埋め込みます。

(5)マクロが終了するとすべてのスライドに以下のような音声が埋め込まれていることが確認できます。

(6)スライドショーの記録を行います。この過程で埋め込んだ音声が再生されます。
　記録されたスライドショーはファイルのエクスポートからビデオを作成することができます。

#ソースコードの内容

VbaUiAuto.cls

UIAutomationを操作する処理をまとめたものになります。

VbaUiAuto.cls

Option Explicit
'* UIAutomationClientを参照設定してください。
Private uia As UIAutomationClient.CUIAutomation
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Sub Class_Initialize()
    Set uia = New UIAutomationClient.CUIAutomation
End Sub
Private Sub Class_Terminate()
    Set uia = Nothing
End Sub
Public Sub SleepMilli(ByVal millisec As Long)
    Call Sleep(millisec)
End Sub
' ルートのディスクトップ要素を取得
Public Function GetRoot() As IUIAutomationElement
    Dim ret As IUIAutomationElement
    Set ret = uia.GetRootElement
    Set GetRoot = ret
End Function

' 指定の子ウィンドウをタイトルから取得する
Public Function GetMainWindowByTitle(ByRef form As IUIAutomationElement, ByVal name As String) As IUIAutomationElement
    Dim cnd As IUIAutomationCondition
    Dim ret As IUIAutomationElement
    Set cnd = uia.CreatePropertyCondition(UIA_PropertyIds.UIA_NamePropertyId, name)

    Set ret = form.FindFirst(TreeScope_Element Or TreeScope_Children, cnd)

    Set GetMainWindowByTitle = ret
End Function

' 指定の子ウィンドウをタイトルから取得できまで待機
Public Function WaitMainWindowByTitle(ByRef form As IUIAutomationElement, ByVal name As String, ByVal timeOutSec As Double) As IUIAutomationElement
    Dim start As Variant
    start = Timer()
    Dim ret As IUIAutomationElement

    Set ret = GetMainWindowByTitle(form, name)
    Do While ret Is Nothing
        If Timer() - start > timeOutSec Then
            Exit Function
        End If
        Set ret = GetMainWindowByTitle(form, name)
        Call SleepMilli(100)
    Loop
    Set WaitMainWindowByTitle = ret
End Function

' ボタンを指定Indexを押下する
Public Sub pushButton(ByRef form As IUIAutomationElement, ByVal ix As Long)
    Dim cnd As IUIAutomationCondition
    Set cnd = uia.CreatePropertyCondition(UIA_PropertyIds.UIA_ClassNamePropertyId, "Button")

    Dim list As IUIAutomationElementArray
    Set list = form.FindAll(TreeScope_Element Or TreeScope_Descendants, cnd)

    Dim ptn As IUIAutomationInvokePattern
    Set ptn = list.GetElement(ix).GetCurrentPattern(UIA_PatternIds.UIA_InvokePatternId)
    Call ptn.Invoke

End Sub


' 指定のClassNameがTextBoxに値を設定する
Public Sub SetText(ByRef form As IUIAutomationElement, ByVal ix As Long, ByVal text As String)
    Dim cnd As IUIAutomationCondition
    Set cnd = uia.CreatePropertyCondition(UIA_PropertyIds.UIA_ClassNamePropertyId, "TextBox")

    Dim list As IUIAutomationElementArray
    Set list = form.FindAll(TreeScope_Element Or TreeScope_Descendants, cnd)


    Dim editValue As IUIAutomationValuePattern
    Set editValue = list.GetElement(ix).GetCurrentPattern(UIA_PatternIds.UIA_ValuePatternId)
    Call editValue.SetValue(text)

End Sub

' 指定のAutomationIdでTextBoxに値を設定する
Public Sub SetTextById(ByRef form As IUIAutomationElement, ByVal id As String, ByVal text As String)
    Dim cnd As IUIAutomationCondition
    Set cnd = uia.CreatePropertyCondition(UIA_PropertyIds.UIA_AutomationIdPropertyId, id)

    Dim list As IUIAutomationElementArray
    Set list = form.FindAll(TreeScope_Element Or TreeScope_Descendants, cnd)


    Dim editValue As IUIAutomationValuePattern
    Set editValue = list.GetElement(0).GetCurrentPattern(UIA_PatternIds.UIA_ValuePatternId)
    Call editValue.SetValue(text)

End Sub

' 指定のClassNameがTextBoxの値を取得する
Public Function GetStatusBarItemText(ByRef form As IUIAutomationElement, ByVal ix As Long) As String
    Dim cnd As IUIAutomationCondition
    Set cnd = uia.CreatePropertyCondition(UIA_PropertyIds.UIA_ClassNamePropertyId, "StatusBarItem")

    Dim list As IUIAutomationElementArray
    Set list = form.FindAll(TreeScope_Element Or TreeScope_Descendants, cnd)

    GetStatusBarItemText = list.GetElement(ix).CurrentName

End Function

VoiceRoid.cls

VOICEROIDE2で音声ファイルを作成するための処理です。
このあたりは二番煎じになっています。

VoiceRoid.cls

Option Explicit
Private vua As VbaUiAuto
Private mainForm As IUIAutomationElement
'*
'* 初期化
'*
Private Sub Class_Initialize()
    Set vua = New VbaUiAuto
    Set mainForm = vua.GetMainWindowByTitle(vua.GetRoot(), "VOICEROID2")
    If (mainForm Is Nothing) Then
        Set mainForm = vua.GetMainWindowByTitle(vua.GetRoot(), "VOICEROID2*")
        If (mainForm Is Nothing) Then
            Err.Raise 999, "VoiceRoid.Init", "VOICEROIDE2が起動していない"
            Exit Sub
        End If
    End If
End Sub

'**
'* VOICEROID2によるWavファイルの作成
'* @param[in] msg しゃべる内容
'* @param[in] wavPath 作成するwavファイルのパス
'**
Public Sub CreateWavFile(ByVal msg As String, ByVal wavPath As String)
    ' 茜ちゃんのセリフ設定
    Call vua.SetText(mainForm, 0, msg)
    
    ' 音声保存
    Call vua.pushButton(mainForm, 4)

    ' 5秒以内に音声保存画面が表示されたら保存ボタンを押す
    Dim saveWvForm As IUIAutomationElement
    Set saveWvForm = vua.WaitMainWindowByTitle(mainForm, "音声保存", 5)
    Call vua.pushButton(saveWvForm, 0)

    ' 名前を付けて保存に日付のファイル名を作る
    Dim saveFileForm As IUIAutomationElement
    Set saveFileForm = vua.WaitMainWindowByTitle(saveWvForm, "名前を付けて保存", 5)
    Call vua.SetTextById(saveFileForm, "1001", wavPath)
    SendKeys "{ENTER}"

    ' 情報ポップアップのOKを押下
    Dim infoForm As IUIAutomationElement
    Set infoForm = vua.WaitMainWindowByTitle(saveWvForm, "情報", 60)
    Call vua.pushButton(infoForm, 0)

End Sub

##Main.bas
スライドショーのノート解析～VOICEROIDE2で作成したWavファイルの埋め込みを行っています。

Main.bas

Option Explicit



'*
'* ノートに書いた内容をスライドの切り替え時にsofttalkを用いてしゃべるようにします。
'* 「画像切り替え」タブのサウンドにそのファイルは指定されています。
'* このリストに追加したファイルはPowerPointerを再起動したときに使用されていなければリストから消えます
'*
Public Sub AddSoftTalk()
    Dim sld As Slide
    Dim note As Slide
    Dim msg As String
    Dim wavPath As String
    ' Visit each slide
    For Each sld In ActivePresentation.Slides
        Call AddSoftTalkToSlide(sld)
    Next
End Sub
'*
'* 選択中のスライドに対して音声を追加する
'*
Public Sub AddSoftTalkToSelectedSlide()
    Dim sld As Slide
    Set sld = ActivePresentation.Slides.Item(ActiveWindow.Selection.SlideRange.SlideIndex)
    Call AddSoftTalkToSlide(sld)
End Sub

Private Sub AddSoftTalkToSlide(ByRef sld As Slide)
    Dim note As Slide
    Dim msg As String
    Dim wavPath As String
    Dim line As Variant
    
    Dim vr As VoiceRoid
    Set vr = New VoiceRoid
    
    Dim i As Long
    
    For Each note In sld.NotesPage
        msg = note.Shapes.Item(2).TextEffect.text
        Debug.Print msg
        If msg <> "" Then
            i = 0
            line = Split(msg, vbCr)
            For i = LBound(line) To UBound(line)
                If line(i) <> "" Then
                    wavPath = ActivePresentation.Path & "\" & sld.name & "_" & i & ".wav"
                    ' Wavファイル作成
                    Call vr.CreateWavFile(line(i), wavPath)
            
                    Call ApeendWavFile(sld, wavPath)
                End If
            Next i
        End If
    Next

End Sub


'**
'* スライドにファイルを追加します。
'* この際全てのShapesをチェックしてすでに追加されていないか確認します。
'* @param[in,out] sld 対象のスライド
'* @param[in] wavPath 作成するwavファイルのパス
'**
Private Sub ApeendWavFile(ByRef sld As Slide, ByVal wavPath As String)
    ' 重複チェック & 削除
    Dim shp As Shape
    Dim rmIndex As Long
    rmIndex = 0
    Dim i As Long
    i = 1
    For Each shp In sld.Shapes
        If shp.Type = msoMedia Then
            If shp.MediaType = ppMediaTypeSound Then
                If Dir(wavPath) = shp.name Then
                    rmIndex = i
                    Exit For
                End If
            End If
        End If
        i = i + 1
    Next
    If rmIndex <> 0 Then
        sld.Shapes.Item(rmIndex).Delete
    End If
    
    Set shp = sld.Shapes.AddMediaObject2(wavPath)
    shp.AnimationSettings.PlaySettings.PlayOnEntry = msoTrue
    shp.AnimationSettings.PlaySettings.HideWhileNotPlaying = msoTrue

    
End Sub

#あとがき
これで茜ちゃんとしてプレゼンテーションができるようになります。