最終版
pythonのpptxがバグがあり、挿入したwavの位置、大きさ、有効化ができない。
wav挿入をパワーポイントのマクロで作りましたが、プログラムが２つになるのは気に食わない
全部パワーポイントのマクロで作り直しました
本当はpythonで作るのがきれいなんですけど！残念！
今回は下記のようにしました
VBAマクロ パワーポイントでプログラミングする言語
パワーポイントのすべてのスライドを取得
スライドからノートを取得
ノートを行に分割
音読のプロが動いているウインドウを見つける
音読のプロウインドウを一番前にする
音声化したい文字をクリップボードに入れる
音読のプロで音声保存操作を行う
スライドに音声を貼り付ける
音声を削除する
パワーポイントのすべてのスライドを取得
スライドのアニメーション一覧を取得
初めの音声を先頭に
音声メディアをアニメーションされてるシェイプの次に配置する
ビデオで保存
とにかくパワーポイントのシェイプに関する情報を調べるのに時間がかかりました。
Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Dim myHwnd As LongPtr
Declare PtrSafe Function SetForegroundWindow Lib "User32" (ByVal hWnd As LongLong) As Long
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Dim s(99) As Integer
Const CPATH = "C:\Users\snortgm\Desktop\1\"
Const INTERVAL = 1500
Type amimateShape
pos As Integer
name As String
End Type
Sub 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 = flg
End Function
Sub 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 If
End 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 sld
MsgBox "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 INTERVAL
End Function