【Word VBA】井桁卍文様描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub 井桁卍文様描画マクロ()

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

    Const DBCRTOPP = 80 　　　　　 '                  Ｙ

    '

    Const DBCRMAGN = 6                  'ポリライン倍率

    Const DBCRCOLS = 5                   '横描画数

    Const DBCRROWS = 3                 '縦描画数

    '

    Const DBCRLNWE = 2                 '線の太さ

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

    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(1, 3, 1, 5, 3, 5, 3, 3, 5, 3, 5, _

    1, 3, 1, 3, -1, 5, -1, 5, -3, 3, -3, 3, -5, 1, _

    -5, 1, -3, -1, -3, -1, -5, -3, -5, -3, -3, -5, _

    -3, -5, -1, -3, -1, -3, 1, -5, 1, -5, 3, -3, 3, _

    -3, 5, -1, 5, -1, 3, 1, 3)

    '

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

    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)) * DBCRMAGN

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

    Next Ip

    '

    For Jp = 0 To DBCRROWS - 1

        For Ip = 0 To DBCRCOLS - 1

            intDxp = (DBCRLEFT + 5 * DBCRMAGN)  _

                  + 8 * DBCRMAGN * Ip - 2 * DBCRMAGN * Jp

            intDyp = (DBCRTOPP + 5 * DBCRMAGN)  _

                 + 8 * DBCRMAGN * Jp + 2 * DBCRMAGN * 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 = msoFalse

                .Line.Visible = msoTrue

                .Line.ForeColor = lngCol

                .Line.Weight = DBCRLNWE

            End With

            '*内の四角形描画

            With ActiveDocument.Shapes.AddShape(msoShapeRectangle, _

                    intDxp - DBCRMAGN, intDyp - DBCRMAGN, _

                    DBCRMAGN * 2, DBCRMAGN * 2)

                .Fill.Visible = msoFalse

                .Line.Visible = msoTrue

                .Line.ForeColor = lngCol

                .Line.Weight = DBCRLNWE

            End With

      Next Ip

  Next Jp

End Sub