【Word VBA】エプロンチェック描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub エプロンチェック描画マクロ()

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

   Const APROTOPP = 100                 '　　　　　　Ｙ

   '

   Const APROHWID = 20                  '横ライン幅

   Const APROVWID = 20                  '縦ライン幅

   Const APROHGAP = 20                  '横間隔

   Const APROVGAP = 20                  '縦間隔

   '

   Const APROCOLS = 6                   '横描画数

   Const APROROWS = 5                  '縦描画数

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

   Dim Ip As Integer, Jp As Integer

   Dim Kp As Integer

   Dim intDxp As Integer, intDyp As Integer

   Dim lngCol(2) As Long

   '

   lngCol(0) = vbWhite                       '←塗りつぶしなし

   lngCol(1) = RGB(238, 130, 238)      '←塗りつぶし１

   lngCol(2) = RGB(148, 0, 211)          '←塗りつぶし２

   For Jp = 0 To APROROWS - 1

       intDyp = APROTOPP + (APROHWID + APROHGAP) * Jp

       For Ip = 0 To APROCOLS - 1

           intDxp = APROLEFT + (APROVWID + APROVGAP) * Ip

           '

           For Kp = 0 To 3                  'K= 0  |   1

                                                    '  -----+----

               '*矩形描画                            2  |   3

               With ActiveDocument.Shapes.AddShape( _

                    msoShapeRectangle, _

                    intDxp + APROVWID * (Kp Mod 2), _

                    intDyp + APROHWID * (Kp \ 2), _

                    IIf((Kp Mod 2) = 0, APROVWID, APROVGAP), _

                    IIf((Kp \ 2) = 0, APROHWID, APROHGAP))

                   .Fill.Visible = True

                   .Fill.ForeColor.RGB = _

                    Choose(Kp + 1, lngCol(2), lngCol(1), _

                                   lngCol(1), lngCol(0))

                   .Line.Visible = False

               End With

           Next Kp

       Next Ip

   Next Jp

End Sub