VBA 角丸四角形の角の丸めサイズを統一するマクロ(Excel・PowePoint・Word対応)

角丸シェイプは普通の四角形に比べて柔らかい印象を与えるため、よく使用される。

しかし普通に配置すると、シェイプのサイズによって角丸のサイズも拡大・縮小するため、丸めサイズが不揃いで格好悪い。

諦めているか、目視で微調整している方がほとんどだと思うけれど、できることなら数値指定でバシッと揃えたい。

ということでマクロの紹介。
角丸シェイプを複数選択した状態でこのマクロを実行すると、角の丸めサイズがきっちり揃う。

Sub AdjustRoundedRectangle()
    '選択中の角丸四角形の角を指定のサイズで丸めるマクロです。
    'ROUND_SIZEに5～20程度の整数を入れて試してみてください。
    'Excel・Word・PowerPontで使用できます。
    'ただしWordのキャンバス内のシェイプには対応していません。
    Const ROUND_SIZE = 10
    Dim sh As Shape
    '↓ActiveWindowはPowerPoint対応のために明示的に記載が必要。
    For Each sh In ActiveWindow.Selection.ShapeRange
        Dim shortEdge As Single
        '角丸のサイズは短辺を基に算出される為、shortEdgeを判定する。
        shortEdge = IIf(sh.Width < sh.Height, sh.Width, sh.Height)
        sh.Adjustments.Item(1) = ROUND_SIZE / shortEdge
    Next
End Sub

丸めサイズの指定はROUND_SIZE定数を変更することで可能。

ただこのマクロは残念なことにWordのキャンバス内のシェイプには対応していない。
そこでキャンバス専用のマクロも用意した。

Sub AdjustRoundedRectangleForWordCanvas()
    '選択されたWordキャンバスに存在するすべての角丸四角形の角を
    '指定のサイズで丸めるマクロです。個別のシェイプ選択には対応していません。
    'ROUND_SIZEに5～20程度の整数を入れて試してみてください。
    Const ROUND_SIZE = 5
    Dim sh As Shape
    For Each sh In Selection.ShapeRange(1).CanvasItems
        If TypeName(sh) = "Shape" Then
            If sh.AutoShapeType = msoShapeRoundedRectangle Then
                Dim shortEdge As Single
                shortEdge = IIf(sh.Width < sh.Height, sh.Width, sh.Height)
                sh.Adjustments.Item(1) = ROUND_SIZE / shortEdge
            End If
        End If
    Next
End Sub

キャンバスに存在する角丸四角形を一つ選択して実行すると、そのキャンバス内のすべての角丸四角形が丸められる。
※これはキャンバス内の選択状態を拾う方法が分からなかった為。

以上