【Word VBA】格子の図形を描画するマクロ▽ソースコード

Option Explicit

Option Base 0

Public Sub 格子描画マクロ()

    Const GRIDXCNT = 6 '横方向格子数

    Const GRIDYCNT = 6 '横方向格子数

    '

    Const GRIDWIDT = 25 '格子幅

    Const GRIDHEIG = 25 '格子高

    '

    Const GRIDLEFT = 80 '格子描画開始位置

    Const GRIDTOP = 100 '

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

    Dim Ip As Integer, Jp As Integer

    Dim varName(0 To GRIDXCNT * GRIDYCNT - 1) As Variant

    For Jp = 0 To GRIDYCNT - 1

        For Ip = 0 To GRIDXCNT - 1

     With ActiveDocument.Shapes.AddShape(msoShapeRectangle, _

             GRIDLEFT + GRIDWIDT * Ip, GRIDTOP + GRIDHEIG * Jp, GRIDWIDT, GRIDHEIG)

                .Fill.Visible = False: .Line.Visible = True

                .Line.ForeColor.RGB = RGB(255, 0, 0) '←線色

                varName(Jp * GRIDXCNT + Ip) = .Name

            End With

        Next Ip

    Next Jp

    ActiveDocument.Shapes.Range(varName).Group '←グループ化

End Sub

Option Explicit

Option Base 0

Public Sub 市松模様描画マクロ()

    Const GRIDXCNT = 6 '横方向格子数

    Const GRIDYCNT = 6 '横方向格子数

    '

    Const GRIDWIDT = 25 '格子幅

    Const GRIDHEIG = 25 '格子高

    '

    Const GRIDLEFT = 80 '格子描画開始位置

    Const GRIDTOP = 100 '

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

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

    Dim varName(0 To GRIDXCNT * GRIDYCNT - 1) As Variant

    For Jp = 0 To GRIDYCNT - 1

        Kp = Jp Mod 2

        For Ip = 0 To GRIDXCNT - 1

     With ActiveDocument.Shapes.AddShape(msoShapeRectangle, _

             GRIDLEFT + GRIDWIDT * Ip, GRIDTOP + GRIDHEIG * Jp, GRIDWIDT, GRIDHEIG)

                .Fill.Visible = True: .Line.Visible = False

                If (Kp Mod 2) = 0 Then .Fill.ForeColor.RGB = RGB(0, 0, 255) _

                                  Else .Fill.ForeColor.RGB = RGB(255, 255, 255)

                Kp = Kp + 1

                varName(Jp * GRIDXCNT + Ip) = .Name

            End With

        Next Ip

    Next Jp

    ActiveDocument.Shapes.Range(varName).Group '←グループ化

End Sub