スポンサーリンク
スポンサーリンク

PowerPoint VBA「半円」を一瞬で作成するマクロ

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

PowerPointで美し過ぎる「半円」を作る2つのテクニック
PowerPointで「半円」の作り方に困ったことはないでしょうか?図形の「部分円」で作れなくはない…

図形ツールに半円を綺麗に描ける図形が含まれていないので、四角形や楕円ほど手軽に作成ができません。

そこで、半円を一瞬で作成できるマクロをご紹介します。

スポンサーリンク

半円を作成するマクロ

Sub 半円を作成()

    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 = 5
    
    '直径を「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.Fill.ForeColor.RGB = RGB(0, 0, 0)
        '図形の線なし
        shp.Line.Visible = msoFalse
        '図形の名前
        shp.Name = "shp2"
        
        '2つの図形を単純型抜き
        .Slides(n).Shapes.Range(Array("shp1", "shp2")) _
        .MergeShapes (msoMergeSubtract)

    End With
End Sub

実行結果

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

半円の幅は「diameter(直径)」の値で変更が可能です。

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