パワポアニメワイプの設定 VBSから方向継続時間グループレベルを設定

PowerPointのアニメワイプ設定操作

＞「ワイプ」で
＞・時間を「0.5秒」から「1秒」に
＞・ワイプ方向を「下から」なのを「左から」に
＞・グループテキストを「第1レベルの段落まで」
＞にしたものを登録してすぐにその状態でアニメーションを割り当てたいのですが、
＞可能でしょうか？

www.youtube.com
https://www.youtube.com/live/9eqfud7dGjs
目次
00:00 1.キッカケの質問
02:17 2.はじめに結果を見せる
09:48 3.VBS設置方法の説明
17:44 4.簡単なコードの説明

1.キッカケは、下記の質問

detail.chiebukuro.yahoo.co.jp

2.はじめに結果を見せる

デスクトップに、VB スクリプトで作成してみました。

vbsをダブルクリックして、設定する
結果を先に見せる

近未来に無くなってしまう、VBSをデスクトップに置く運用イメージで作成してみました。
5分時間を下さい、下記動画内の運用イメージで良ければコードを使ってみてください。

https://www.youtube.com/live/9eqfud7dGjs?si=opKUu9fGQSaFiepu&t=186

↑が運用・操作イメージです。デスクトップ置いたスクリプトを起動させてます。
※powerPointのアドインにした方がよさそうだなぁと回答している今、気が付いたり・・

3.VBS設置方法の説明

メモ帳で新規にデスクトップにテキストを作成する
拡張子を.vbsに変更する
下記のソースをコピペする

貼り付け終わったら、
保存で、ANSIを選択する
https://www.youtube.com/live/9eqfud7dGjs?si=Nri27wNWZuvOtuGm&t=724
※↑コメントやメッセージで日本語使っているので保存で、ANSIを選択してください

'----  XXXX.vbs で 保存して使ってください

Call Main231018() '処理を呼ぶ

Sub Main231018()  'アニメのワイプを付ける

'定数を頭で代入
ppSelectionShapes = 2
msoAnimEffectWipe = 22 'ワイプ効果
msoAnimTriggerOnPageClick = 1  'クリック後 
msoAnimDirectionLeft = 4 '方向左→を指定 
msoAnimateTextByFirstLevel = 2  '第1レベル 
    
    '起動済みのパワポを捕まえる
    Dim ppApp
    
    Set ppApp = Nothing
    On Error Resume Next  'エラーが発生しても強引に次の命令に行け
    Set ppApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0  '忘れないで戻すぞ

    If ppApp Is Nothing Then
        MsgBox "パワポが見つかりません"
        Exit Sub
    End If

    'ppSelectionShapes 2
    If ppApp.ActiveWindow.Selection.Type <> ppSelectionShapes Then
        MsgBox "Shape全体 図形やテキストボックスを選択してね"
        Exit Sub
    End If

    Dim nPAGE
    Dim objSLD   'スライド
    Dim objShape 'シェイプ
    
    nPAGE = ppApp.ActiveWindow.Selection.SlideRange.SlideIndex '現在選択しているページ
    Set objSLD = ppApp.ActivePresentation.Slides(nPAGE)  'プレゼンの下、スライドnページをセット
    
    'アニメ効果
    Dim objTimeLine 'アニメタイムライン
    Set objTimeLine = objSLD.TimeLine  'スライドの下にタイムラインがあります
  
    '↑このタイムラインにアニメ効果を追加していくイメージです
    Dim objEffect '効果
    
    '複数選択のアニメを追加後、効果をセット
    Dim n
    For n = 1 To ppApp.ActiveWindow.Selection.ShapeRange.Count '選択された数までループ
        Set objShape = ppApp.ActiveWindow.Selection.ShapeRange(n) '←このシェイプを↓アニメ効果を追加
        'msoAnimEffectWipe   22  ↑の選択シェイプにワイプ効果を付ける
        Set objEffect = objTimeLine.MainSequence.AddEffect(objShape, msoAnimEffectWipe)
        'msoAnimEffectWipe   22  ワイプ効果 効果の中身をセット
        With objEffect
            .Timing.TriggerType = msoAnimTriggerOnPageClick  'クリック後 msoAnimTriggerOnPageClick=1
            .EffectParameters.Direction = msoAnimDirectionLeft '方向左→を指定 msoAnimDirectionLeft=4
            .Timing.Duration = 1  'アニメーションの長さを秒単位
            .Timing.TriggerDelayTime = 0  '遅延時間を秒数で設定
        End With
      
        '↑効果のレベル変更 でテキストのアニメーションをコンバートする
        '第1レベル msoAnimateTextByFirstLevel  2   コンバート？違う方法無いかなぁ・・・
        '.ConvertToBuildLevel で 変更する
        Dim effConvert
        Set effConvert = objTimeLine.MainSequence.ConvertToBuildLevel(objEffect, msoAnimateTextByFirstLevel)
	'↑行が長いので、コピペ折り返しに注意
    Next

    MsgBox "処理終了、アニメーションウインドで確認してください"

End Sub

'ここまで

4.簡単なコードの説明

.MainSequence.AddEffect(objShape, msoAnimEffectWipe)
で、ワイプ効果のアニメを作成する

4.1 方向
方向を左にしたかったので、
.EffectParameters.Direction = msoAnimDirectionLeft '方向左→を指定 msoAnimDirectionLeft=4

4.2 継続時間など 0.5から1秒にプロパティをセット

.Timing タイミングに値をセットする
.Timing.TriggerType = msoAnimTriggerOnPageClick 'クリック後 msoAnimTriggerOnPageClick=1
msoAnimDirectionLeft=4
.Timing.Duration = 1 'アニメーションの長さを秒単位
.Timing.TriggerDelayTime = 0 '遅延時間を秒数で設定

4.3 段落のレベルを設定

設定なので XXXプロパティ=レベルと思ったが、
コンバート.ConvertToBuildLevelで、複数の段落アニメを作るイメージ
'↑効果のレベル変更でテキストのアニメーションをコンバートする
'第1レベル msoAnimateTextByFirstLevel 2 コンバート？違う方法無いかなぁ・・・
'.ConvertToBuildLevel で変更する
Dim effConvert
Set effConvert = objTimeLine.MainSequence.ConvertToBuildLevel(objEffect, msoAnimateTextByFirstLevel)