【Word VBA】松皮麻の葉文様描画マクロ▽ソースコード

Option Explicit

Option Base 0

Public Sub 松皮麻の葉文様描画マクロ()

    Const PSHPLEFT = 80　　　　         '描画開始位置Ｘ

    Const PSHPTOPP = 100　　　　       '　　　　　　Ｙ

    Const PSHPLENG = 35                     '三角形一辺長さ

   '

    Const PSHPCOLS = 7                       '描画列数

    Const PSHPROWS = 4                     '描画行数

   '

    Const PSHPLWEI = 1#                    '線の太さ

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

    Dim Ip As Integer, Jp As Integer, Kp As Integer

    Dim intHei As Integer, blnUpp As Boolean

    Dim intCxp As Integer, intCyp As Integer

    Dim intXps(3) As Integer, intYps(3) As Integer

    Dim lngCol As Long

    '

    lngCol = RGB(184, 134, 11)                      '←線色

    intHei = CInt(PSHPLENG / 2 * Sqr(3))       '三角形高さ

    For Jp = 0 To PSHPROWS - 1

        intCyp = PSHPTOPP + intHei * Jp

        For Ip = 0 To PSHPCOLS - 1

            intCxp = PSHPLEFT + (PSHPLENG / 2) * Ip

            blnUpp = IIf(((Jp + Ip) Mod 2) = 0, True, False)

            '*三角頂点座標把握

            If blnUpp = True Then

               intXps(0) = intCxp + PSHPLENG / 2:

               intYps(0) = intCyp: intXps(1) = intCxp

               intYps(1) = intCyp + intHei

               intXps(2) = intCxp + PSHPLENG

               intYps(2) = intCyp + intHei

            Else

               intXps(0) = intCxp

               intYps(0) = intCyp

               intXps(1) = intCxp + PSHPLENG

               intYps(1) = intCyp

               intXps(2) = intCxp + PSHPLENG / 2:

               intYps(2) = intCyp + intHei

            End If

            '*三角形重心座標算出

            intXps(3) = (intXps(0) + intXps(1) + intXps(2)) \ 3

            intYps(3) = (intYps(0) + intYps(1) + intYps(2)) \ 3

            '

            For Kp = 0 To 2

                Call ギザギザ描画(intXps(Kp), intYps(Kp), _

          intXps((Kp + 1) Mod 3), intYps((Kp + 1) Mod 3), _

                 lngCol, PSHPLWEI)

                Call ギザギザ描画(intXps(Kp), intYps(Kp), _

                     intXps(3), intYps(3), lngCol, PSHPLWEI)

            Next Kp

        Next Ip

    Next Jp

End Sub

'*(ギザギザ描画)-------------------------------------------------

Public Sub ギザギザ描画(pintXsp As Integer, pintYsp As Integer, _

       pintXep As Integer, pintYep As Integer, plngCol As Long, _

       psngWei As Single)

    Dim Ip As Integer

    Dim intXps(4) As Integer, intYps(4) As Integer

    Dim dblAtn As Double, dblSiz As Double

    '*中点位置取得

    intXps(0) = pintXsp + (pintXep - pintXsp) \ 2

    intYps(0) = pintYsp + (pintYep - pintYsp) \ 2

    '

    If (pintXep - pintXsp) <> 0 Then

       dblAtn = Atn((pintYep - pintYsp) / (pintXep - pintXsp))

    Else

       dblAtn = 0

    End If

    If dblAtn = 0 Then dblAtn = 1 Else dblAtn = dblAtn + 2

    '

    dblSiz = Sqr((pintYep - pintYsp) ^ 2 + (pintXep - pintXsp) ^ 2) / 16

    '１----->２

    '　　　／

    '　　３-------> ４

    intXps(2) = intXps(0) + dblSiz * Cos(dblAtn)

    intYps(2) = intYps(0) + dblSiz * Sin(dblAtn)

    intXps(3) = intXps(0) - dblSiz * Cos(dblAtn)

    intYps(3) = intYps(0) - dblSiz * Sin(dblAtn)

    intXps(1) = pintXsp: intYps(1) = pintYsp

    intXps(4) = pintXep: intYps(4) = pintYep

    '

    '*線描画

    For Ip = 1 To 3

        With ActiveDocument.Shapes.AddLine(intXps(Ip), intYps(Ip), _

                            intXps(Ip + 1), intYps(Ip + 1)).Line

             .ForeColor.RGB = plngCol '←線色

             .Weight = psngWei '←線の太さ

        End With

    Next Ip

End Sub