【VBA】シェイプで正六角形を作成

正六角形

図形の六角形では正六角形にならなかったため
フリーフォーム：図形で作成することにした。

Sub Hexagon()
    
    'シェイプの中心位置
    Dim centerX As Double:  centerX = 200
    Dim centerY As Double:  centerY = 200
    
    'シェイプのサイズ
    Dim shpSize As Double:  shpSize = 50
    
    '円周率3.14...
    Dim pi As Double: pi = 4 * Atn(1)
    
    Dim x1 As Double: x1 = centerX - shpSize * Sin(30 * pi / 180)
    Dim y1 As Double: y1 = centerY - shpSize * Cos(30 * pi / 180)
    Dim x2 As Double: x2 = centerX + shpSize * Sin(30 * pi / 180)
    Dim y2 As Double: y2 = centerY - shpSize * Cos(30 * pi / 180)
    Dim x3 As Double: x3 = centerX + shpSize
    Dim y3 As Double: y3 = centerY
    Dim x4 As Double: x4 = centerX + shpSize * Sin(30 * pi / 180)
    Dim y4 As Double: y4 = centerY + shpSize * Cos(30 * pi / 180)
    Dim x5 As Double: x5 = centerX - shpSize * Sin(30 * pi / 180)
    Dim y5 As Double: y5 = centerY + shpSize * Cos(30 * pi / 180)
    Dim x6 As Double: x6 = centerX - shpSize
    Dim y6 As Double: y6 = centerY
    
    'フリーフォーム：図形で６角形シェイプ作成
    With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, x1, y1)
        .AddNodes msoSegmentLine, msoEditingAuto, x2, y2
        .AddNodes msoSegmentLine, msoEditingAuto, x3, y3
        .AddNodes msoSegmentLine, msoEditingAuto, x4, y4
        .AddNodes msoSegmentLine, msoEditingAuto, x5, y5
        .AddNodes msoSegmentLine, msoEditingAuto, x6, y6
        .AddNodes msoSegmentLine, msoEditingAuto, x1, y1
        .ConvertToShape.Name = "Hexagon1"
    End With
    
    'シェイプを変数に格納
    Dim hexaShp As Shape
    Set hexaShp = ActiveSheet.Shapes("Hexagon1")
    
    '名前と色設定
    With hexaShp
        .Fill.ForeColor.RGB = RGB(0, 112, 192) '塗りつぶし色
        .Line.Visible = msoFalse '枠線無し
    End With
    
End Sub

周辺に六角形を配置してみた

１個出来てしまえば位置を指定するだけで増殖できる。

Sub 展開_六角形()

    'クリックしたシェイプ
    Dim shp As Shape
    Set shp = ActiveSheet.Shapes(Application.Caller)
    
    'クリックしたシェイプの中心
    Dim shpX As Double: shpX = shp.Left + shp.Width / 2
    Dim shpY As Double: shpY = shp.Top - shp.Height / 2

    Dim size As Double: size = shp.Width / 2

    '円周率3.14...
    Dim pi As Double: pi = 4 * Atn(1)
    
    Dim X0 As Double: X0 = shp.Left + shp.Width / 2
    Dim Y0 As Double: Y0 = shp.Top + shp.Height / 2
    
    '隙間設定
    Dim gap As Double
    gap = 5
    
    Dim centerX(1 To 6) As Double
    centerX(1) = X0
    centerX(2) = X0 + shp.Width - shp.Width / 4 + gap * Cos(30 * pi / 180)
    centerX(3) = X0 + shp.Width - shp.Width / 4 + gap * Cos(30 * pi / 180)
    centerX(4) = X0
    centerX(5) = X0 - shp.Width + shp.Width / 4 - gap * Cos(30 * pi / 180)
    centerX(6) = X0 - shp.Width + shp.Width / 4 - gap * Cos(30 * pi / 180)
    
    Dim centerY(1 To 6) As Double
    centerY(1) = Y0 - shp.Height - gap
    centerY(2) = Y0 - shp.Height / 2 - gap / 2
    centerY(3) = Y0 + shp.Height / 2 + gap / 2
    centerY(4) = Y0 + shp.Height + gap
    centerY(5) = Y0 + shp.Height / 2 + gap / 2
    centerY(6) = Y0 - shp.Height / 2 - gap / 2

    Dim i As Long
    For i = 1 To 6

        Dim shpName As String: shpName = "Hexa" & i
                        
        Dim x1 As Double: x1 = centerX(i) - size * Sin(30 * pi / 180)
        Dim y1 As Double: y1 = centerY(i) - size * Cos(30 * pi / 180)
        Dim x2 As Double: x2 = centerX(i) + size * Sin(30 * pi / 180)
        Dim y2 As Double: y2 = centerY(i) - size * Cos(30 * pi / 180)
        Dim x3 As Double: x3 = centerX(i) + size
        Dim y3 As Double: y3 = centerY(i)
        Dim x4 As Double: x4 = centerX(i) + size * Sin(30 * pi / 180)
        Dim y4 As Double: y4 = centerY(i) + size * Cos(30 * pi / 180)
        Dim x5 As Double: x5 = centerX(i) - size * Sin(30 * pi / 180)
        Dim y5 As Double: y5 = centerY(i) + size * Cos(30 * pi / 180)
        Dim x6 As Double: x6 = centerX(i) - size
        Dim y6 As Double: y6 = centerY(i)
        
        'シェイプ作成
        With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, x1, y1)
            .AddNodes msoSegmentLine, msoEditingAuto, x2, y2
            .AddNodes msoSegmentLine, msoEditingAuto, x3, y3
            .AddNodes msoSegmentLine, msoEditingAuto, x4, y4
            .AddNodes msoSegmentLine, msoEditingAuto, x5, y5
            .AddNodes msoSegmentLine, msoEditingAuto, x6, y6
            .AddNodes msoSegmentLine, msoEditingAuto, x1, y1
            .ConvertToShape.Name = shpName
        End With
        '名前と色設定
        With ActiveSheet.Shapes(shpName)
            .Fill.ForeColor.RGB = RGB(0, 112, 192) '塗りつぶし色
            .Line.Visible = msoFalse '枠線無し
            '回転
        End With

        Application.Wait [Now()] + 50 / 86400000

    Next i
    
End Sub