【Word VBA】平行四角形模様描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub 平行四角形模様描画マクロ()

    Const PRLLLEFT = 90 　　　　　　　'描画開始位置Ｘ

    Const PRLLTOPP = 80　　　 　　　   '　　　　　　Ｙ

    '

    Const PRLLSWID = 24                     '描画幅

    Const PRLLSHEI = 24                      '描画高さ

    '

    Const PRLLVSPC = -6                      '横-間隔

    Const PRLLHSPC = 0                       '縦-間隔

    Const PRLLCOLS = 10                     '横/描画数

    Const PRLLROWS = 7                     '縦/描画数

    '

    Const PRLLLNWE = 1.5                   '線の太さ

    Const PRLLANGL = 0.5                    '辺の傾き

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

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer, lngCol(1) As Long

    Dim intDxp As Integer, intDyp As Integer

    '

    lngCol(0) = RGB(128, 128, 0)              '←塗りつぶし色１

    lngCol(1) = RGB(255, 0, 0)                 '←塗りつぶし色２

    For Jp = 0 To PRLLROWS - 1

        intDyp = PRLLTOPP + (PRLLSHEI + PRLLHSPC) * Jp

        For Ip = 0 To PRLLCOLS - 1

            intDxp = PRLLLEFT + (PRLLSWID + PRLLVSPC) * Ip

            For Kp = 0 To 1

                '*平行四辺形描画　(上/下)

                With ActiveDocument.Shapes.AddShape( _

                     msoShapeParallelogram, _

                          intDxp, intDyp _

                                + (PRLLSHEI \ 2) * Kp, _

                          PRLLSWID, PRLLSHEI \ 2)

                    .Fill.Visible = msoTrue

                    .Fill.ForeColor.RGB = _

                         IIf((Ip Mod 2) = 0, _

                         lngCol(Kp), lngCol(1 - Kp))

                    .Line.Visible = msoFalse

                    .Adjustments(1) = PRLLANGL

                    If Kp = 1 Then　　'下側なら上下反転

                      .Flip msoFlipVertical

                    End If

                End With

            Next Kp

        Next Ip

    Next Jp

End Sub