PowerPointでVBAを使う（４） タイトルスライドをVBAで作る

はじめに

VBAを使うことが目的です。
デザインの良し悪しについては主観が入るのでここでは触れないでください。
以下のYouTube動画のデザインを使わせてもらいました。
https://www.youtube.com/watch?v=4NOx4Cy4iQM

出来上がり

背景画像のダウンロード

背景画像は下記からダウンロードさせて頂きました。
640×422を選択して「E:\富士山.jpg」として保存。
https://pixabay.com/ja/photos/%E6%B9%96-%E5%AF%8C%E5%A3%AB%E5%B1%B1-%E3%82%B5%E3%83%B3%E3%82%BB%E3%83%83%E3%83%88-%E6%B0%B4-5519047/

VBAコード

ActivePresentation.Slides.Add Index:=1, Layout:=ppLayoutBlank
ActiveWindow.View.GotoSlide Index:=1

ActivePresentation.Slides(1).FollowMasterBackground = msoFalse
    
With ActivePresentation.Slides(1).Background.Fill
    .ForeColor.RGB = RGB(255, 255, 255)
    .TwoColorGradient msoGradientHorizontal, 1
    .GradientStops.Insert RGB(255, 255, 255), 0.5
    .GradientStops.Insert RGB(200, 215, 240), 1
    .GradientStops.Delete (2)
End With
    
Dim sld_w As Single ''スライドの横幅
Dim sld_h As Single ''スライドの高さ
sld_w = ActivePresentation.PageSetup.SlideWidth
sld_h = ActivePresentation.PageSetup.SlideHeight

Dim rect_left(1 To 9) As Single

For i = 1 To 7 Step 3
    rect_left(i) = 0
Next i

For i = 2 To 8 Step 3
    rect_left(i) = 210
Next i

For i = 3 To 9 Step 3
    rect_left(i) = 420
Next i


Dim rect_top(1 To 9) As Single

For i = 1 To 3
    rect_top(i) = 420
Next i

For i = 4 To 6
    rect_top(i) = 210
Next i

For i = 7 To 9
    rect_top(i) = 0
Next i

For i = 1 To 9
    With ActivePresentation.Slides(1).Shapes.AddShape(msoShapeRectangle, rect_left(i), rect_top(i), 200, 200)
        .Line.Visible = msoFalse
        .Select
    End With

    ActiveWindow.Selection.ShapeRange.Name = "rect_" + Str(i)
Next i

ActivePresentation.Slides(1).Shapes.SelectAll

With ActiveWindow.Selection.ShapeRange
    .Group
    .Rotation = 45
    .Align msoAlignMiddles, msoTrue
    .Left = 500
    .Ungroup
End With

ActivePresentation.Slides(1).Shapes("rect_ 1").Delete

For i = 2 To 9
    With ActivePresentation.Slides(1).Shapes.AddPicture(FileName:="E:\富士山.jpg", LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0, Width:=sld_w, Height:=sld_h)
        .Select
    End With

    ActivePresentation.Slides(1).Shapes("rect_" + Str(i)).Select Replace:=msoFalse

    With ActiveWindow.Selection.ShapeRange
        .MergeShapes msoMergeIntersect
    End With
Next i

動作環境

以下の環境で作成しています。

Windows 10
Office Home and Business 2019