PowerPointでVBAを使う（２） 画像をななめに切るアニメーション

はじめに

VBAを使って画像をななめに切るアニメーションを作ってみた。
特殊なことをしているわけではなく、普段GUIを使って行う作業をコードにしただけ。

結果

画像のダウンロード

画像は下記からダウンロードさせて頂いた。
「D:\fruit.png」として保存。
www.irasutoya.com
各自で画像を用意すればそれが使えます。その場合コード内のパスを変更してください。

VBAコード

PowerPointを立ち上げてすぐの状態（空白スライドが１枚存在する状態）で以下のマクロを実行する。
３枚のスライドが出来上がるのでスライドショーにして見てください。
エディタにコードをコピペする時には最初の「Sub 切るアニメーション()」と最後の「End Sub」が重複しないように気を付けてください。

Sub 切るアニメーション()

'========================各自の設定========================
Dim img_file As String  '画像ファイルのパス
img_file = "D:\fruit.png"

Dim move As Integer     'どれだけ動かすか
move = 30
'========================各自の設定========================


Dim sld_w As Single ''スライドの横幅
Dim sld_h As Single ''スライドの高さ
    
sld_w = ActivePresentation.PageSetup.SlideWidth
sld_h = ActivePresentation.PageSetup.SlideHeight

Dim triangle_w As Integer
Dim triangle_h As Integer

triangle_w = sld_h / 2
triangle_h = sld_h


'========================スライドを1枚追加する========================
ActivePresentation.Slides.Add Index:=1, Layout:=ppLayoutBlank
'========================スライドを二枚追加する========================


ActiveWindow.View.GotoSlide Index:=2

'========================右側の図形を追加========================
With ActivePresentation.Slides(2).Shapes.AddShape(msoShapeRectangle, sld_w / 2 + triangle_w / 2, 0, sld_w / 2 - triangle_w / 2, sld_h)
    .Line.Visible = msoFalse
    .Select
End With

With ActivePresentation.Slides(2).Shapes.AddShape(msoShapeRightTriangle, sld_w / 2 - triangle_w / 2, 0, triangle_w, triangle_h)
    .Line.Visible = msoFalse
    .Rotation = 180
    .Flip msoFlipVertical
    .Select Replace:=msoFalse
End With

With ActiveWindow.Selection.ShapeRange
    .MergeShapes msoMergeUnion
    .Select
End With

ActiveWindow.Selection.ShapeRange.Name = "Shape_right"
'========================右側の図形を追加========================


'========================画像をカット（右側）========================
With ActivePresentation.Slides(2).Shapes.AddPicture(FileName:=img_file, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=100, Top:=100)
    .Select
End With

With ActiveWindow.Selection.ShapeRange
    .Name = "fruit"
    .Align msoAlignCenters, msoTrue
    .Align msoAlignMiddles, msoTrue
    .Select
End With

ActivePresentation.Slides(2).Shapes("Shape_right").Select Replace:=msoFalse

With ActiveWindow.Selection.ShapeRange
    .MergeShapes msoMergeIntersect
    .Select
End With

ActiveWindow.Selection.ShapeRange.Name = "img_right"
'========================画像をカット（右側）========================


'========================左側の図形を追加========================
With ActivePresentation.Slides(2).Shapes.AddShape(msoShapeRectangle, 0, 0, sld_w / 2 - triangle_w / 2, sld_h)
    .Line.Visible = msoFalse
    .Select
End With

With ActivePresentation.Slides(2).Shapes.AddShape(msoShapeRightTriangle, sld_w / 2 - triangle_w / 2, 0, triangle_w, triangle_h)
    .Line.Visible = msoFalse
    .Flip msoFlipVertical
    .Select Replace:=msoFalse
End With

With ActiveWindow.Selection.ShapeRange
    .MergeShapes msoMergeUnion
    .Select
End With

ActiveWindow.Selection.ShapeRange.Name = "Shape_left"
'========================左側の図形を追加========================


'========================画像をカット（左側）========================
With ActivePresentation.Slides(2).Shapes.AddPicture(FileName:=img_file, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=100, Top:=100)
    .Select
End With

With ActiveWindow.Selection.ShapeRange
    .Name = "fruit"
    .Align msoAlignCenters, msoTrue
    .Align msoAlignMiddles, msoTrue
    .Select
End With

ActivePresentation.Slides(2).Shapes("Shape_left").Select Replace:=msoFalse

With ActiveWindow.Selection.ShapeRange
    .MergeShapes msoMergeIntersect
    .Select
End With

ActiveWindow.Selection.ShapeRange.Name = "img_left"
'========================画像をカット（左側）========================


'========================2枚目のスライドを複製========================
ActivePresentation.Slides(2).Duplicate
'========================2枚目のスライドを複製========================


'========================3枚目のスライド内の画像を移動させる========================
Dim x_position As Integer
Dim y_position As Integer

x_position = ActivePresentation.Slides(3).Shapes("img_left").Left
y_position = ActivePresentation.Slides(3).Shapes("img_left").Top
ActivePresentation.Slides(3).Shapes("img_left").Left = x_position - move
ActivePresentation.Slides(3).Shapes("img_left").Top = y_position + move * 2

x_position = ActivePresentation.Slides(3).Shapes("img_right").Left
y_position = ActivePresentation.Slides(3).Shapes("img_right").Top
ActivePresentation.Slides(3).Shapes("img_right").Left = x_position + move
ActivePresentation.Slides(3).Shapes("img_right").Top = y_position - move * 2
'========================3枚目のスライド内の画像を移動させる========================


'========================1枚目にも画像を貼り付ける========================
ActiveWindow.View.GotoSlide Index:=1
With ActivePresentation.Slides(1).Shapes.AddPicture(FileName:=img_file, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=100, Top:=100)
    .Select
End With

With ActiveWindow.Selection.ShapeRange
    .Align msoAlignCenters, msoTrue
    .Align msoAlignMiddles, msoTrue
End With
'========================1枚目にも画像を貼り付ける========================


'========================2枚目のスライドの画面切り替えタイミングを自動にする========================
With ActivePresentation.Slides(2).SlideShowTransition
    .AdvanceOnTime = msoTrue
    .AdvanceTime = 0#
End With
'========================2枚目のスライドの画面切り替えタイミングを自動にする========================


'========================3枚目のスライドの画面切り替えを変形（3954）にする========================
ActivePresentation.Slides(3).SlideShowTransition.EntryEffect = 3954
'========================3枚目のスライドの画面切り替えを変形（3954）にする========================

End Sub

動作環境

以下の環境で作成した。

Windows 10
Office Home and Business 2019