【VBA】エクセルで寸法線を描画

エクセルで寸法線を簡易的に描画してみました。

今回はセル幅のピクセル(px)を表示してみましたが、
テキストボックスなので自分で数値は書き換え可能で、

後で幅を手動で変更も可能です。

選択したセル幅を取得する

横幅はこれで取れます。

Selection.width

縦幅はこちら

Selection.height

引き出し線と矢印を描画する

参考で上側の引き出し線のコードで説明します。

左右の線と矢印を描画する

    Dim 範囲 As Range: Set 範囲 = Selection
    
    Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
    Dim shp1 As Object, shp2 As Object, shp3 As Object
    
    '左側の引き出し線
    x1 = 範囲.left
    y1 = 範囲.top
    x2 = 範囲.left
    y2 = 範囲.top + 範囲.height
    Call 直線(x1, y1, x2, y2)
    Set shp1 = Selection.ShapeRange

    '右側の引き出し線
    x1 = 範囲.left + 範囲.width
    y1 = 範囲.top
    x2 = 範囲.left + 範囲.width
    y2 = 範囲.top + 範囲.height
    Call 直線(x1, y1, x2, y2)
    Set shp2 = Selection.ShapeRange
    
    '矢印線
    x1 = 範囲.left
    y1 = 範囲.top + 10
    x2 = 範囲.left + 範囲.width
    y2 = 範囲.top + 10
    Call 両矢印(x1, y1, x2, y2)
    Set shp3 = Selection.ShapeRange

Private Sub 直線(ByVal x1 As Double, ByVal y1 As Double, _
                    ByVal x2 As Double, ByVal y2 As Double)

    With ActiveSheet.Shapes.AddConnector(msoConnectorStraight, x1, y1, x2, y2)
        .Line.ForeColor.rgb = rgbRed
        .Line.Weight = 1.5
        .Select
    End With

End Sub

Private Sub 両矢印(ByVal x1 As Double, ByVal y1 As Double, _
                    ByVal x2 As Double, ByVal y2 As Double)

    With ActiveSheet.Shapes.AddConnector(msoConnectorStraight, x1, y1, x2, y2)
        .Line.ForeColor.rgb = rgbRed
        .Line.Weight = 1.5
        .Line.BeginArrowheadStyle = msoArrowheadOpen
        .Line.EndArrowheadStyle = msoArrowheadOpen
        .Select
    End With

End Sub

寸法値を計算して表示する

テキストボックスを配置する

    Dim shp4 As Object
    Dim テキストサイズ As Long: テキストサイズ = 50

    '寸法表示
    Dim x位置 As Double, y位置 As Double
    x位置 = 範囲.left + 範囲.width / 2
    y位置 = 範囲.top + 10 - テキストサイズ / 3 / 2
    Call 寸法(x位置, y位置, テキストサイズ, 範囲.width)
    Set shp4 = Selection.ShapeRange

Private Sub 寸法(ByVal x位置 As Double, ByVal y位置 As Double, _
                    ByVal テキストサイズ As Long, 寸法 As Double)
            
    'ポイントをピクセルに変換
    寸法 = Round(寸法 * 4 / 3, 3)
    
    '中心に原点を持ってくる
    Dim l As Double: l = x位置 - テキストサイズ / 2)
    Dim t As Double: t = y位置 - (テキストサイズ / 3 / 2)
    
    '描画
    With ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, _
        left:=l, top:=t, width:=テキストサイズ, height:=テキストサイズ / 3)
        .Fill.Visible = msoFalse '塗りつぶし無し
        .Line.Visible = msoFalse '線無し
        With .TextFrame
            .Characters.text = 寸法 & "px" 'テキスト
            .Characters.Font.Color = rgbBlack 'テキスト色
            .Characters.Font.size = 12      'フォントサイズ
            .HorizontalAlignment = xlHAlignCenter   '左右中央揃え
            .VerticalAlignment = xlVAlignCenter     '上下中央揃え
            .HorizontalOverflow = xlOartHorizontalOverflowOverflow  '横にはみ出して表示
            .VerticalOverflow = xlOartHorizontalOverflowOverflow    '縦にはみ出して表示
            .MarginLeft = 3     '左余白
            .MarginRight = 0    '右余白
            .MarginTop = 0      '上余白
            .MarginBottom = 0   '下余白
        End With
        With .TextFrame2
            .WordWrap = msoFalse '図形内でテキストを折り返さない
            'フォントの光彩（白の縁取り）
            With .TextRange.Font.Glow
                .Color = rgbWhite
                .Transparency = 0
                .Radius = 10
            End With
        End With
        .Select
    End With

End Sub

最後にグループ化して図形の選択を解除しておく

    'グループ化
    shp1.Select Replace:=False 'False:拡張選択
    shp2.Select Replace:=False 'False:拡張選択
    shp3.Select Replace:=False 'False:拡張選択
    shp4.Select Replace:=False 'False:拡張選択
    Selection.Group

    範囲.Select

End Sub