【Word VBA】千鳥格子描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub 千鳥格子描画マクロ()

    Const HOTOLEFT = 100 　　　　　　'描画開始位置Ｘ

    Const HOTOTOPP = 120 　　　　　  '                  Ｙ

    Const HOTOMAGN = 10                   'ポリライン倍率

    Const HOTOCOLS = 6                      '横描画数

    Const HOTOROWS = 4                    '縦描画数

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

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer

    Dim intDxp As Integer, intDyp As Integer

    Dim varPos As Variant, lngCol As Long

    Dim sngBas() As Single, sngDat() As Single

    '

    '

    '*ポリラインデータ元データ

    varPos = Array(0, -2, -1, -2, -3, 0, -2, 0, -1, -1, -1, 0, _

    0, 0, -1, 1, -1, 2, 1, 0, 1, -1, 2, -2, 1, -2, 1, -3, 0, -2)

    '

    lngCol = RGB(30, 144, 255)             '←塗りつぶし色

    Ip = (UBound(varPos, 1) - 1) \ 2

    ReDim sngBas(Ip, 1), sngDat(Ip, 1)

    '*ポリラインデータ設定

    For Ip = LBound(varPos, 1) To UBound(varPos, 1) Step 2

        sngBas(Ip \ 2, 0) = CSng(varPos(Ip + 0)) * HOTOMAGN

        sngBas(Ip \ 2, 1) = CSng(varPos(Ip + 1)) * HOTOMAGN

    Next Ip

    '

    For Jp = 0 To HOTOROWS - 1

        intDyp = HOTOTOPP + 4 * HOTOMAGN * Jp

        For Ip = 0 To HOTOCOLS - 1

            intDxp = HOTOLEFT + 4 * HOTOMAGN * Ip

            '描画位置設定

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

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

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

            Next Kp

            '*ポリライン描画

            With ActiveDocument.Shapes.AddPolyline(sngDat)

                .Fill.Visible = msoTrue

                .Fill.ForeColor = lngCol

                .Line.Visible = msoFalse

            End With

      Next Ip

  Next Jp

End Sub