ぎゅっと四字熟語パズル【素人 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
[画像]
