4 パワーポイント動画作成(アニメーションとナレーション入り)
最終版『パワーポイント ビデオ作製 音声の改善』生徒に便利なように次の操作をしているパワーポイントのノートを音声合成でスライドに自動挿入しているこのスライドをビデオに変換すると、いつでもプレゼンを見られるし…ameblo.jppythonのpptxがバグがあり、挿入したwavの位置、大きさ、有効化ができない。wav挿入をパワーポイントのマクロで作りましたが、プログラムが2つになるのは気に食わない全部パワーポイントのマクロで作り直しました本当はpythonで作るのがきれいなんですけど!残念!今回は下記のようにしましたVBAマクロ パワーポイントでプログラミングする言語パワーポイントのすべてのスライドを取得 スライドからノートを取得 ノートを行に分割 音読のプロが動いているウインドウを見つける 音読のプロウインドウを一番前にする 音声化したい文字をクリップボードに入れる 音読のプロで音声保存操作を行う スライドに音声を貼り付ける 音声を削除する パワーポイントのすべてのスライドを取得 スライドのアニメーション一覧を取得 初めの音声を先頭に 音声メディアをアニメーションされてるシェイプの次に配置する ビデオで保存とにかくパワーポイントのシェイプに関する情報を調べるのに時間がかかりました。Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" ( _ ByVal lpClassName As String, _ ByVal lpWindowName As String) As LongPtrDim myHwnd As LongPtrDeclare PtrSafe Function SetForegroundWindow Lib "User32" (ByVal hWnd As LongLong) As LongPrivate Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)Dim s(99) As IntegerConst CPATH = "C:\Users\snortgm\Desktop\1\"Const INTERVAL = 1500Type amimateShape pos As Integer name As StringEnd TypeSub test() Debug.Print reOrderAminateShape(1)End Sub'アニメーションの順番変更 既存シェイプに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 = flgEnd FunctionSub 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 IfEnd 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 = CPATH & "tmp.wav" FileName = CPATH & fn 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 CPATH & "*.wav" Kill CPATH & "*.txt"End Sub'ノートを取得して、1行ごとに音声ファイルを作成するSub getNote() Dim sld As Slide For Each sld In ActivePresentation.Slides Dim shp As Shape Set shp = sld.NotesPage.Shapes.Placeholders(2) w = shp.TextFrame.TextRange.Text w2 = Split(w, vbCr) sid = sld.SlideNumber n = 0 For k = 0 To UBound(w2) fn = "wav_" & sid & "_" & n & ".wav" ' fn = "tmp.wav" wline = w2(k) Call createwav(fn, wline) Call SlideVoice(sid, fn) n = n + 1 Next Next sldMsgBox "done"End Sub '文字を送りWAVファイルを作成するFunction createwav(fn, word) Dim r As LongPtr r = FindWindow(vbNullString, "音読のプロ Premium") SetForegroundWindow (r) Dim cbData As New DataObject cbData.SetText word cbData.PutInClipboard Sleep 100 SendKeys ("%"), True SendKeys ("F"), True SendKeys ("W"), True SendKeys (fn), True SendKeys ("{ENTER}"), True Sleep INTERVALEnd Function