【Word VBA】業平菱文様描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub 業平菱文様描画マクロ()

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

    Const NARITOPP = 90 　　　　　　 '　　　　　　Ｙ

    Const NARILENG = 40                    'ひし形長い対角線長さ

    Const NARICOLS = 5                      '列数

    Const NARIROWS = 10                   '行数

    '

    Const NATILNW1 = 2                      '線の太さ1

    Const NATILNW2 = 1                      '線の太さ2

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

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer, lngCol As Long

    Dim intWiD As Integer, intHei As Integer

    Dim intWiH As Integer, intHeH As Integer

    Dim intWiS As Integer, intHeS As Integer

    Dim intWiO As Integer, intHeO As Integer

    Dim intCxp As Integer, intCyp As Integer

    Dim intDxp(1) As Integer, intDyp(1) As Integer

    '

    intWiD = NARILENG

    intHei = CInt(NARILENG * 0.618)                     '*黄金比

    intWiH = intWiD / 2: intHeH = intHei / 2

    intWiS = intWiD / 12: intHeS = intHei / 12        '←線間隔

    intWiO = intHei / 8: intHeO = intHei / 20          '←花びらサイズ

    '

    '

    lngCol = RGB(255, 20, 147) '←線色

    For Jp = 0 To NARIROWS - 1

        intCyp = NARITOPP + (intHei / 2) * Jp + intHeH

        For Ip = 0 To NARICOLS - 1

            intCxp = NARILEFT + intWiD * Ip _

            + IIf((Jp Mod 2) = 0, 0, intWiD / 2) + intWiH

            '*ひし形外形描画

            For Kp = 1 To 4

                intDxp(0) = intCxp _

                          + intWiH * Choose(Kp, 0, 1, 0, -1)

                intDyp(0) = intCyp _

                          + intHeH * Choose(Kp, -1, 0, 1, 0)

                intDxp(1) = intCxp _

                          + intWiH * Choose(Kp, 1, 0, -1, 0)

                intDyp(1) = intCyp _

                          + intHeH * Choose(Kp, 0, 1, 0, -1)

               '*ひし形描画

                With ActiveDocument.Shapes.AddLine( _

                     intDxp(0), intDyp(0), intDxp(1), intDyp(1)).Line

                    .ForeColor.RGB = lngCol

                    .Weight = NATILNW1

                 End With

                 intDxp(0) = intDxp(0) _

                         - intWiS * Choose(Kp, 1, 1, -1, -1)

                 intDyp(0) = intDyp(0) _

                         + intHeS * Choose(Kp, 1, -1, -1, 1)

                 intDxp(1) = intDxp(1) _

                         - intWiS * Choose(Kp, 1, 1, -1, -1)

                 intDyp(1) = intDyp(1) _

                         + intHeS * Choose(Kp, 1, -1, -1, 1)

               '*ひし形の内側の線描画

                 With ActiveDocument.Shapes.AddLine( _

                     intDxp(0), intDyp(0), intDxp(1), intDyp(1)).Line

                    .ForeColor.RGB = lngCol

                    .Weight = NATILNW2

                 End With

            Next Kp

            '*ひし形の中央の線描画

            For Kp = 1 To 2

               intDxp(0) = intCxp - intWiH / 2

               intDyp(0) = intCyp + intHeH / 2 * Choose(Kp, -1, 1)

               intDxp(1) = intCxp + intWiH / 2

               intDyp(1) = intCyp + intHeH / 2 * Choose(Kp, 1, -1)

                With ActiveDocument.Shapes.AddLine( _

                     intDxp(0), intDyp(0), intDxp(1), intDyp(1)).Line

                    .ForeColor.RGB = lngCol

                    .Weight = NATILNW2

               End With

            Next Kp

            '*花びら(楕円)描画

            For Kp = 1 To 4

                intDxp(0) = intCxp _

                          + (intWiH / 4) * Choose(Kp, 0, 1, 0, -1)

                intDyp(0) = intCyp _

                          + (intHeH / 4) * Choose(Kp, -1, 0, 1, 0)

                intDxp(1) = Choose(Kp, intHeO, intWiO, intHeO, intWiO)

                intDyp(1) = Choose(Kp, intWiO, intHeO, intWiO, intHeO)

                With ActiveDocument.Shapes.AddShape(msoShapeOval, _

                     intDxp(0) - intDxp(1), _

                     intDyp(0) - intDyp(1), _

                     intDxp(1) * 2, intDyp(1) * 2)

                    .Fill.Visible = msoTrue

                    .Fill.ForeColor.RGB = lngCol

                    .Line.Visible = msoFalse

                End With

            Next Kp

        Next Ip

    Next Jp

End Sub