PowerPointで雲枠を作図したい

メモ

PowerPoint 2013で下図のような雲枠を作図したい。

雲枠

フリーフォームのような操作性で雲枠を作図するのは難しそうなので、とりあえず円弧を単純に並べてグループ化した図形を素材として利用することを考えた。

雲枠 素材

使い捨てマクロ

' PowerPoint 2013
' 標準モジュール
Option Explicit

Private Function MillimetersToPoints(ByVal millimeters As Double) As Double
    ' 1[in] = 25.4[mm]
    ' 1[pt] = 1[in] / 72 = (25.4/72)[mm]
    MillimetersToPoints = millimeters * 72 / 25.4
End Function

Public Sub Main()
    Dim pr As PowerPoint.Presentation
    Dim sld As PowerPoint.Slide
    Dim shps As PowerPoint.Shapes
    Dim shpr As PowerPoint.ShapeRange
    Dim shp As PowerPoint.Shape
    Dim str() As String
    Dim i As Long, k As Long

    Set pr = PowerPoint.Presentations.Add

    ' スライドのサイズを設定
    With pr.PageSetup
        .SlideWidth = MillimetersToPoints(841)
        .SlideHeight = MillimetersToPoints(594)
    End With

    ' スライドマスター(2番目以降)を削除
    With pr.Designs
        For i = .Count To 2 Step -1
            .Item(i).Delete
        Next i
    End With

    ' スライドマスター(1番目)の図形を全て削除
    With pr.Designs.Item(1).SlideMaster.Shapes
        For i = .Count To 1 Step -1
            .Item(i).Delete
        Next i
    End With

    ' スライドマスター(1番目)内にあるレイアウト(2番目以降)を削除
    With pr.Designs.Item(1).SlideMaster.CustomLayouts
        For i = .Count To 2 Step -1
            .Item(i).Delete
        Next i
    End With

    With pr.Designs.Item(1).SlideMaster.CustomLayouts.Item(1).Shapes
        For i = .Count To 1 Step -1
            .Item(i).Delete
        Next i
    End With

    Set sld = pr.Slides.AddSlide( _
                Index:=1, _
                pCustomLayout:= _
                pr.Designs.Item(1).SlideMaster.CustomLayouts.Item(1) _
                )

    Set shps = sld.Shapes

    For i = 1 To 140 Step 2
        ' 弧のサイズは1個あたり 横3mm * 縦3mm
        ' 対象とする用紙サイズはA3横(420mm*297mm)を想定する
        ' 横420mm / 横3mm = 140個

        ReDim str(1 To i)

        For k = 1 To i Step 1
            Set shp = shps.AddShape( _
                        Type:=Office.MsoAutoShapeType.msoShapeArc, _
                        Left:=MillimetersToPoints(3 * (k - 1) + 1.5), _
                        Top:=MillimetersToPoints(3 * (i - 1)), _
                        Width:=MillimetersToPoints(1.5), _
                        Height:=MillimetersToPoints(1.5) _
                        )
            shp.Adjustments.Item(1) = 0
            shp.Adjustments.Item(2) = 180
            shp.Line.Weight = 0.75
            shp.Line.ForeColor.RGB = VBA.Information.RGB(192, 0, 0)
            shp.Name = "arc-h-" & VBA.Strings.Format(k, "000") & _
                        "-" & VBA.Strings.Format(i, "000")

            str(k) = shp.Name
        Next k

        If i >= 2 Then
            Set shpr = shps.Range(str)
            Set shp = shpr.Group
            shp.Name = "arc-h-" & VBA.Strings.Format(i, "000")
        End If
    Next i

    For i = 1 To 99 Step 2
        ' 弧のサイズは1個あたり 横3mm * 縦3mm
        ' 対象とする用紙サイズはA3横(420mm*297mm)を想定する
        ' 縦297mm / 縦3mm = 99個

        ReDim str(1 To i)

        For k = 1 To i Step 1
            Set shp = shps.AddShape( _
                        Type:=Office.MsoAutoShapeType.msoShapeArc, _
                        Left:=MillimetersToPoints(3 * (i - 1) + 1.5), _
                        Top:=MillimetersToPoints(3 * (k - 1)), _
                        Width:=MillimetersToPoints(1.5), _
                        Height:=MillimetersToPoints(1.5) _
                        )
            shp.Adjustments.Item(1) = -90
            shp.Adjustments.Item(2) = 90
            shp.Line.Weight = 0.75
            shp.Line.ForeColor.RGB = VBA.Information.RGB(192, 0, 0)
            shp.Name = "arc-v-" & VBA.Strings.Format(k, "000") & _
                        "-" & VBA.Strings.Format(i, "000")

            str(k) = shp.Name
        Next k

        If i >= 2 Then
            Set shpr = shps.Range(str)
            Set shp = shpr.Group
            shp.Name = "arc-v-" & VBA.Strings.Format(i, "000")
        End If
    Next i

End Sub