【Word VBA】毘沙門亀甲文様描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub 毘沙門亀甲文様描画マクロ()

    Const BTTLLEFT = 120                '描画開始位置Ｘ

    Const BTTLTOPP = 110               '　　　　　　Ｙ

    '

    Const BTTLPSIZ = 10                  'ピースサイズ

    '

    Const BTTLCOLS = 7                  '横/描画数

    Const BTTLROWS = 5                '縦/描画数

    '

    Const BTTLLNWE = 1.5              '線の太さ

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

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer

    Dim intDxp As Integer, intDyp As Integer

    Dim intDwd As Integer, intDht As Integer

    Dim sngRnd As Single, sngAng As Single

    Dim sngBas(12, 1) As Single, sngPol(12, 1) As Single

    Dim lngCol(1) As Long

    '

    '*ポリラインデータ作成

    sngRnd = (4 * Atn(1)) / 180

    For Ip = 0 To 11

        Select Case Ip

               Case 0, 1, 2, 3:

                    intDxp = 0

                    intDyp = 0 - BTTLPSIZ

                    sngAng = sngRnd * (60 * (Ip + 3) + 30)

               Case 4, 5, 6, 7:

                    intDxp = 0 + BTTLPSIZ * Sqr(3) / 2

                    intDyp = 0 + BTTLPSIZ / 2

                    sngAng = sngRnd * (60 * (Ip + 1) + 30)

               Case 8, 9, 10, 11

                    intDxp = 0 - BTTLPSIZ * Sqr(3) / 2

                    intDyp = 0 + BTTLPSIZ / 2

                    sngAng = sngRnd * (60 * (Ip - 7) + 30)

        End Select

        sngBas(Ip, 0) = BTTLPSIZ * Cos(sngAng) + intDxp

        sngBas(Ip, 1) = BTTLPSIZ * Sin(sngAng) + intDyp

    Next Ip

    sngBas(12, 0) = sngBas(0, 0): sngBas(12, 1) = sngBas(0, 1)

    '

    lngCol(0) = RGB(144, 238, 144)             '←塗りつぶし色

    lngCol(1) = RGB(34, 139, 34)                '←線色

    '

    intDwd = BTTLPSIZ * (Sqr(3) * 3) / 2

    intDht = BTTLPSIZ * 3

    For Jp = 0 To BTTLROWS - 1

        For Ip = 0 To BTTLCOLS - 1

            intDxp = BTTLLEFT + intDwd * Ip

            intDyp = BTTLTOPP + intDht * Jp _

                   + (BTTLPSIZ + BTTLPSIZ * 1 / 2) * (Ip Mod 2)

            '*ポリライン位置設定

            For Kp = LBound(sngBas, 1) To UBound(sngBas, 1)

                sngPol(Kp, 0) = sngBas(Kp, 0) + intDxp

                sngPol(Kp, 1) = sngBas(Kp, 1) + intDyp

            Next Kp

            '*ポリライン描画

            With ActiveDocument.Shapes.AddPolyline(sngPol)

                .Fill.Visible = msoTrue

                .Fill.ForeColor = lngCol(0)          '←塗りつぶし色

                .Line.Visible = msoTrue

                .Line.ForeColor = lngCol(1)        '←線色

                .Line.Weight = BTTLLNWE         '←線の太さ

            End With

        Next Ip

    Next Jp

End Sub