PowerPointでVBAを使う（１）　画面が割れるアニメーションを作る

PowerPoint

動機

以下のYouTube動画を見て同じものを作ってみたくなった。
パワポ かっこいいオープニングスライドの作り方 / Power point - YouTube
ネット上のVBAコードを切った貼ったしてなんとか動作するものを作った。

背景画像のダウンロード

背景画像は下記からダウンロードさせて頂いた。
「D:\海のイラスト.png」として保存。
threestardesign.com

VBAコード

Sub オープニングを作る()

ActivePresentation.Slides.Add Index:=1, Layout:=ppLayoutBlank

For i = 1 To 2
    With ActivePresentation.Slides(i)
        .FollowMasterBackground = msoFalse
        .Background.Fill.UserPicture "D:\海のイラスト.png"
    End With
Next i

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

Dim textframe_width As Integer
Dim textframe_height As Integer

textframe_width = 400
textframe_height = 40

With ActivePresentation.Slides(2).Shapes.AddTextbox(msoTextOrientationHorizontal, (sld_w - textframe_width) / 2, (sld_h - textframe_height) / 2, textframe_width, textframe_height)
    .TextFrame.TextRange = "サンプル"
    .TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)
    .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
    .TextEffect.FontSize = 60
    .TextEffect.FontBold = msoCTrue
End With


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

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

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

ActiveWindow.Selection.ShapeRange.Name = "left_back"

With ActivePresentation.Slides(2).Shapes("left_back").Shadow
    .Visible = True
    .OffsetX = 5
    .OffsetY = 5
    .Transparency = 0.5
End With
'========================左側の図形を追加（影付き）========================


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

With ActivePresentation.Slides(2).Shapes.AddShape(msoShapeRightTriangle, sld_w / 2 - 100, 0, 200, sld_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 = "right_back"

With ActivePresentation.Slides(2).Shapes("right_back").Shadow
    .Visible = True
    .OffsetX = -5
    .OffsetY = -5
    .Transparency = 0.5
End With
'========================右側の図形を追加（影付き）========================


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

With ActivePresentation.Slides(2).Shapes.AddShape(msoShapeRightTriangle, sld_w / 2 - 100, 0, 200, sld_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"
ActivePresentation.Slides(2).Shapes("Shape_left").Fill.Background
'========================左側の図形を追加========================


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

With ActivePresentation.Slides(2).Shapes.AddShape(msoShapeRightTriangle, sld_w / 2 - 100, 0, 200, sld_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"
ActivePresentation.Slides(2).Shapes("Shape_right").Fill.Background
'========================右側の図形を追加========================


'========================アニメーションを追加========================
With ActivePresentation.Slides(2)
    .TimeLine.MainSequence.AddEffect Shape:=.Shapes("Shape_left"), effectId:=msoAnimEffectPathLeft, trigger:=msoAnimTriggerAfterPrevious
    .TimeLine.MainSequence.AddEffect Shape:=.Shapes("left_back"), effectId:=msoAnimEffectPathLeft, trigger:=msoAnimTriggerWithPrevious
    .TimeLine.MainSequence.AddEffect Shape:=.Shapes("Shape_right"), effectId:=msoAnimEffectPathRight, trigger:=msoAnimTriggerWithPrevious
    .TimeLine.MainSequence.AddEffect Shape:=.Shapes("right_back"), effectId:=msoAnimEffectPathRight, trigger:=msoAnimTriggerWithPrevious
End With
'========================アニメーションを追加========================

End Sub

動作環境

以下の環境で作成した。

Windows 10
Office Home and Business 2019

【修正履歴】

2020年11月26日コードを修正しました。
スライドショーを実行した時に真ん中に線がうつることがあったためコードを修正してスライドを2枚にしました。
以下は修正前の古いコードです。

Sub オープニングを作る()

With ActivePresentation.Slides(1)
      .FollowMasterBackground = msoFalse
      .Background.Fill.UserPicture "D:\海のイラスト.png"
End With

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

Dim textframe_width As Integer
Dim textframe_height As Integer

textframe_width = 400
textframe_height = 40

With ActivePresentation.Slides(1).Shapes.AddTextbox(msoTextOrientationHorizontal, (sld_w - textframe_width) / 2, (sld_h - textframe_height) / 2, textframe_width, textframe_height)
    .TextFrame.TextRange = "サンプル"
    .TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)
    .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
    .TextEffect.FontSize = 60
    .TextEffect.FontBold = msoCTrue
End With


'========================左側の図形を追加（影付き）========================
With ActivePresentation.Slides(1).Shapes.AddShape(msoShapeRectangle, 0, 0, sld_w / 2 - 100, sld_h)
    .Line.Visible = msoFalse
    .Select
End With

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

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

ActiveWindow.Selection.ShapeRange.Name = "left_back"

With ActivePresentation.Slides(1).Shapes("left_back").Shadow
    .Visible = True
    .OffsetX = 5
    .OffsetY = 5
    .Transparency = 0.5
End With
'========================左側の図形を追加（影付き）========================


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

With ActivePresentation.Slides(1).Shapes.AddShape(msoShapeRightTriangle, sld_w / 2 - 100, 0, 200, sld_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 = "right_back"

With ActivePresentation.Slides(1).Shapes("right_back").Shadow
    .Visible = True
    .OffsetX = -5
    .OffsetY = -5
    .Transparency = 0.5
End With
'========================右側の図形を追加（影付き）========================


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

With ActivePresentation.Slides(1).Shapes.AddShape(msoShapeRightTriangle, sld_w / 2 - 100, 0, 200, sld_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"
ActivePresentation.Slides(1).Shapes("Shape_left").Fill.Background
'========================左側の図形を追加========================


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

With ActivePresentation.Slides(1).Shapes.AddShape(msoShapeRightTriangle, sld_w / 2 - 100, 0, 200, sld_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"
ActivePresentation.Slides(1).Shapes("Shape_right").Fill.Background
'========================右側の図形を追加========================


'========================アニメーションを追加========================
With ActivePresentation.Slides(1)
    .TimeLine.MainSequence.AddEffect Shape:=.Shapes("Shape_left"), effectId:=msoAnimEffectPathLeft
    .TimeLine.MainSequence.AddEffect Shape:=.Shapes("left_back"), effectId:=msoAnimEffectPathLeft, trigger:=msoAnimTriggerWithPrevious
    .TimeLine.MainSequence.AddEffect Shape:=.Shapes("Shape_right"), effectId:=msoAnimEffectPathRight, trigger:=msoAnimTriggerWithPrevious
    .TimeLine.MainSequence.AddEffect Shape:=.Shapes("right_back"), effectId:=msoAnimEffectPathRight, trigger:=msoAnimTriggerWithPrevious
End With
'========================アニメーションを追加========================

End Sub

このエントリーをはてなブックマークに追加