ぎゅっと四字熟語パズル【素人 PowerPoint マクロ】

Microsoft officeのVBAでマクロを組みましたので公開します。
インターネットで検索したり、マクロの記録機能を使ったり、AIに考えてもらったりしたのを組み合わせだけなので、上手くはないですが、一応動くはずです。
office2021です。
必ず、元データのバックアップを取ってから実行してください。
素人の作ったものなので、信用しすぎないでください。

［仕様］
テキストボックスに四字熟語を入力し、選択して実行。
四分の一分割された漢字の図形が出力されます。

［コード］

Sub ぎゅっと四字熟語パズル()
    ' 選択した形状を取得
    If ActiveWindow.Selection.ShapeRange.Count <> 1 Then
        MsgBox "テキストボックスを一つだけ選択してください。"
        Exit Sub
    End If
    
    Dim shp As Shape
    Set shp = ActiveWindow.Selection.ShapeRange(1)
    
    ' テキストが4文字か判定
    Dim txt As String
    txt = shp.TextFrame.textRange.text
    If Len(txt) <> 4 Then
        MsgBox "四字熟語ではありません"
        Exit Sub
    End If
    
    ' 漢字4文字かどうかを確認（簡易的な判定方法）
    Dim i As Integer
    For i = 1 To 4
        If Not (Mid(txt, i, 1) Like "[一-龠々〆?]" And Len(Mid(txt, i, 1)) = 1) Then
            MsgBox "四字熟語ではありません"
            Exit Sub
        End If
    Next i

    ' 漢字一文字ずつテキストボックスに分ける
    Dim shapes As Collection
    Set shapes = New Collection
    
    Dim newShape As Shape
    Dim textRange As textRange
    Dim slideIndex As Integer
    slideIndex = shp.Parent.slideIndex

    For i = 1 To 4
        Set newShape = ActivePresentation.Slides(slideIndex).shapes.AddTextbox _
            (Orientation:=msoTextOrientationHorizontal, Left:=shp.Left, Top:=shp.Top, Width:=200, Height:=200)
        newShape.TextFrame.textRange.text = Mid(txt, i, 1)
        newShape.TextFrame.textRange.Font.Size = 66
        newShape.TextFrame.textRange.ParagraphFormat.Alignment = ppAlignCenter
        newShape.TextFrame.VerticalAnchor = msoAnchorMiddle
        newShape.TextFrame.AutoSize = ppAutoSizeNone
        newShape.TextFrame.MarginLeft = 0
        newShape.TextFrame.MarginRight = 0
        newShape.TextFrame.MarginTop = 0
        newShape.TextFrame.MarginBottom = 0
        
        
      ' テキストボックスのサイズを文字のサイズに合わせる
        Set textRange = newShape.TextFrame.textRange
        newShape.Width = textRange.BoundWidth + 75
        newShape.Height = textRange.BoundHeight + 75
        
        
        shapes.Add newShape
    Next i

      ' テキストボックスを画像に変換する
    Dim picShapes As Collection
    Set picShapes = New Collection
    
    Dim picShape As Shape
    For Each newShape In shapes
        newShape.Copy
        ActiveWindow.View.PasteSpecial DataType:=ppPasteEnhancedMetafile
        Set picShape = ActivePresentation.Slides(slideIndex).shapes(ActivePresentation.Slides(slideIndex).shapes.Count)
        picShapes.Add picShape
        newShape.Delete
    Next newShape

    ' テキストボックスをトリミングする
    picShapes(1).PictureFormat.CropTop = 0
    picShapes(1).PictureFormat.CropBottom = picShapes(1).Height / 2
    picShapes(1).PictureFormat.CropLeft = picShapes(1).Width / 2
    picShapes(1).PictureFormat.CropRight = 0
    
    picShapes(2).PictureFormat.CropTop = picShapes(2).Height / 2
    picShapes(2).PictureFormat.CropBottom = 0
    picShapes(2).PictureFormat.CropLeft = picShapes(2).Width / 2
    picShapes(2).PictureFormat.CropRight = 0
    
    picShapes(3).PictureFormat.CropTop = 0
    picShapes(3).PictureFormat.CropBottom = picShapes(3).Height / 2
    picShapes(3).PictureFormat.CropLeft = 0
    picShapes(3).PictureFormat.CropRight = picShapes(3).Width / 2
    
    picShapes(4).PictureFormat.CropTop = picShapes(4).Height / 2
    picShapes(4).PictureFormat.CropBottom = 0
    picShapes(4).PictureFormat.CropLeft = 0
    picShapes(4).PictureFormat.CropRight = picShapes(4).Width / 2

    ' トリミング後の画像に黒の枠線を追加
    Dim borderShape As Shape
    For Each borderShape In picShapes
        With borderShape.Line
            .Visible = msoTrue
            .ForeColor.RGB = RGB(0, 0, 0)
            .Weight = 1
        End With
    Next borderShape

    ' テキストボックスを合体させる
    picShapes(1).Left = shp.Left + shp.Width / 2 - 20
    picShapes(1).Top = shp.Top
    
    picShapes(2).Left = shp.Left + shp.Width / 2 - 20
    picShapes(2).Top = shp.Top + shp.Height / 2 + 65
    
    picShapes(3).Left = shp.Left
    picShapes(3).Top = shp.Top
    
    picShapes(4).Left = shp.Left
    picShapes(4).Top = shp.Top + shp.Height / 2 + 65
    
    ' 元のテキストボックスを削除
    shp.Delete
    
    
    MsgBox "処理が完了しました。"
End Sub

[画像]

自画自賛

半信半疑

単刀直入