PowerPoint VBA 1/4円を一瞬で作成するマクロ

スポンサーリンク

PowerPointで「1/4円」を作成する方法は、以前ご紹介しました。

PowerPointで正確な「1/4円」を一瞬で作る方法
PowerPointで正確な「1/4円」を図形を組み合わせて一瞬で作る方法をご紹介します。適当に「1…

図形の部分円を使うと1/4円を作ることができますが、アバウトにしか作れないため、あまりオススメではありません。

図形の結合で作ると手間がかかるため、マクロで作成して作業効率化を図りましょう。

スポンサーリンク

1/4円を作成するマクロ

Sub 図形の1分の4円を作成()

    Dim n As Long
    Dim w As Double
    Dim h As Double
    Dim diameter As Double
    Dim shp As Shape
    
    '選択中のスライド番号を取得
    n = ActiveWindow.Selection.SlideRange.SlideIndex
    
    'スライドサイズ取得
    w = ActivePresentation.PageSetup.SlideWidth
    h = ActivePresentation.PageSetup.SlideHeight
    
    '円の直径「cm」を入力
    diameter = 6
    
    '直径を「cm」に変換
    diameter = Round(diameter * 720 / 25.4, 1)

    With ActivePresentation

        '正円を作成
        Set shp = .Slides(n).Shapes.AddShape( _
        Type:=msoShapeOval, _
        Left:=(w - diameter) / 2, _
        Top:=(h - diameter) / 2, _
        Width:=diameter, _
        Height:=diameter)
        
        '図形の色
        shp.Fill.ForeColor.RGB = RGB(0, 0, 0)
        '図形の線なし
        shp.Line.Visible = msoFalse
        '図形の名前
        shp.Name = "shp1"
        
        '長方形を作成
        Set shp = .Slides(n).Shapes.AddShape( _
        Type:=msoShapeRectangle, _
        Left:=(w - diameter) / 2, _
        Top:=(h - diameter) / 2 + diameter / 2, _
        Width:=diameter, _
        Height:=diameter / 2)

        '図形の名前
        shp.Name = "shp2"
        
        '長方形を作成
        Set shp = .Slides(n).Shapes.AddShape( _
        Type:=msoShapeRectangle, _
        Left:=(w - diameter) / 2, _
        Top:=(h - diameter) / 2, _
        Width:=diameter / 2, _
        Height:=diameter)

        '図形の名前
        shp.Name = "shp3"
        
        '3つの図形を単純型抜き
        .Slides(n).Shapes.Range(Array("shp1", "shp2", "shp3")) _
        .MergeShapes (msoMergeSubtract)

    End With
End Sub

実行結果

マクロを実行すると、スライドの中央に黒色の1/4円が作成されます。

1/4円の幅は「diameter(直径)」の値の1/2になります。

  • PowerPoint 2016 for Macでは「MergeShapes」メソッドが使用できないため、コンパイルエラーになります。