【Word VBA】三つ巴模様描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub 三つ巴模様描画マクロ()

    Const TOMOLEFT = 90                     '描画開始位置Ｘ

    Const TOMOTOPP = 80                    '　　　　　　Ｙ

    '

    Const TOMOSIZE = 12                    '内側円直径

    Const TOMORADI = TOMOSIZE / 2  '内側円半径

    Const TOMOHZSP = 25                   '水平間隔

    Const TOMOVTSP = 70                   '垂直間隔

    Const TOMOCOLS = 4                    '横 描画数

    Const TOMOROWS = 6                   '縦 描画数

    '

    Const TOMOLNWE = 1                    '線の太さ

    '---------------------------------------------------------------------------

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer, lngCol As Long

    Dim intCxp As Integer, intCyp As Integer

    Dim intDxp As Integer, intDyp As Integer

    Dim intTri(2, 1) As Integer, intRad As Integer

    '

    '*三角形頂点座標

    intTri(0, 0) = 0: intTri(0, 1) = 0 - (TOMORADI * Sqr(3)) * (2 / 3)

    intTri(1, 0) = 0 - TOMORADI

　 intTri(1, 1) = 0 + (TOMORADI * Sqr(3)) * (1 / 3)

    intTri(2, 0) = 0 + TOMORADI

　 intTri(2, 1) = intTri(1, 1)

    '*外円半径

    intRad = (TOMORADI * Sqr(3)) * (2 / 3) + TOMORADI

    '

    lngCol = RGB(160, 82, 45)　　　　           '←線色

    For Jp = 0 To TOMOROWS - 1

        intCyp = TOMOLEFT + TOMOHZSP * Jp

        For Ip = 0 To TOMOCOLS - 1

            If (Jp Mod 2) = 0 Or Ip < TOMOCOLS - 1 Then

               intCxp = TOMOLEFT + TOMOVTSP * Ip  _

                                             + (TOMOVTSP / 2) * (Jp Mod 2)

               For Kp = 0 To 2

                   intDxp = intCxp + intTri(Kp, 0)

                   intDyp = intCyp + intTri(Kp, 1)

                   '*円弧描画

                   With ActiveDocument.Shapes.AddShape(msoShapeArc, _

                        intDxp - TOMORADI, intDyp - TOMORADI, _

                        TOMOSIZE, TOMOSIZE)

                        .Fill.Visible = msoFalse

                        .Line.Visible = msoTrue

                        .Line.ForeColor.RGB = lngCol

                        .Line.Weight = TOMOLNWE

                        .Adjustments(1) = Choose(Kp + 1, 60, -60, -180)

                        .Adjustments(2) = Choose(Kp + 1, 270, 150, 0)

                   End With

               Next Kp

               '*外円描画

               With ActiveDocument.Shapes.AddShape(msoShapeOval, _

                    intCxp - intRad, intCyp - intRad, _

                                     intRad * 2, intRad * 2)

                   .Fill.Visible = msoFalse

                   .Line.Visible = msoTrue

                   .Line.ForeColor.RGB = lngCol

                   .Line.Weight = TOMOLNWE

               End With

            End If

        Next Ip

    Next Jp

End Sub