ピクミンのポストカードのリストを作れるようにしたい

f:id:elve:20211205120302p:plain
何も考えずにみどりの小野 (id:yutoma233)さんにポストカードを送っていたのですが、これはこれで記録したほうがいいのか！？　（もらったポストカードは見れるけど送ったポストカードは見れない）
しかしこれ・・・面倒だな・・・と。

結果イメージ
処理イメージ
下準備
ソース
参考
落ち

結果イメージ

はてなブログにダーッと貼った感じ
f:id:elve:20211205113428p:plain

処理イメージ

ポストカードを送る時にスクショ撮っておきます。
↓はピクミンから受け取るときのｗ
f:id:elve:20211205113328p:plain

サイズが1125*2436px

これを沢山パワーポイントにドロップダウンしてマクロで

上下トリミング
名前部分マスク
スクショ1枚ずつを新しいスライドに移動
左上に配置

はてさて。

下準備

スライドサイズ
f:id:elve:20211205114121p:plain
スライドのレイアウトを「白紙」に
f:id:elve:20211205114322p:plain

沢山のスクショを選択してパワポにドロップダウンすると、重なって中央に縮小さてて配置されます。
この状態で、図形四角を重ねて、名前が隠れるように配置してください。その頭の名前を「目隠し」とします。
f:id:elve:20211205114915p:plain

ソース

Sub test()
Dim sld As Slide: Set sld = ActivePresentation.Slides(1)
Dim sh As Shape
Dim sh2 As ShapeRange
Dim i As Integer: i = 0
Dim pptLayout As CustomLayout: Set pptLayout = ActivePresentation.Slides(1).CustomLayout
Dim pptSlide As Slide

'このスライドの中の図形をすべて順番に処理
For Each sh In sld.Shapes
    
    '目隠し以外なら処理
    If sh.Name <> "目隠し" Then
        
        'トリミング
        sld.Select
        sh.ZOrder msoBringToFront
        sh.PictureFormat.CropTop = 582
        sh.PictureFormat.CropBottom = 400
        
        '目隠しをコピーして最前面同じ位置へ
        sld.Shapes("目隠し").Copy
        Set sh2 = sld.Shapes.Paste
        sh2.Name = "目隠し" & i
        sh2.ZOrder msoBringToFront
        sh2.Left = sld.Shapes("目隠し").Left
        sh2.Top = sld.Shapes("目隠し").Top
        
        'スクショと目隠し（コピー）を切り取り
        sld.Shapes.Range(Array(sh.Name, sh2.Name)).Cut
        i = i + 1
        
        'スライド追加　貼り付け(png)
        Set pptSlide = ActivePresentation.Slides.AddSlide(ActivePresentation.Slides.Count + 1, pptLayout)
        pptSlide.Shapes.PasteSpecial (ppPastePNG)
        
        '高さを19センチ　左上
        pptSlide.Shapes(1).Height = 19 * 72 / 2.54
        pptSlide.Shapes(1).Left = 0
        pptSlide.Shapes(1).Top = 0
    End If
Next
End Sub