【Word VBA】工字繋ぎ文様描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub 工字繋ぎ文様描画マクロ()

    Const KOJILEFT = 120                         '描画開始位置Ｘ

    Const KOJITOPP = 100                        '　　　　　　Ｙ

    Const KOJITEVA = 0.2　　　　　　　　 'データ作成倍率

    Const KOJITEVB = KOJITEVA * -10

    Const KOJICOLS = 8 　　　　　　　　  '描画列数

    Const KOJIROWS = 3 　　　　　　　　 '描画行数

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

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

    Dim varPosi As Variant

    Dim sngBase() As Single, sngData() As Single

    Dim lngColr(1) As Long

    '

    '*工字の線データ

    varPosi = Array(10, 10, 250, 10, 250, 10, 250, 110, 250, 110, _

    210, 110, 210, 110, 210, 50, 210, 50, 150, 50, 150, 50, 150, _

    280, 150, 280, 210, 280, 210, 280, 210, 220, 210, 220, 250, _

    220, 250, 220, 250, 320, 250, 320, 10, 320, 10, 320, 10, 220, _

    10, 220, 50, 220, 50, 220, 50, 280, 50,280, 110, 280, 110, 280, _

    110, 50, 110, 50, 50, 50, 50, 50, 50, 110, 50, 110, 10, 110, 10, _

    110, 10, 10)

    '

    ReDim sngBase((UBound(varPosi, 1) - 1) \ 2, 1)

    ReDim sngData((UBound(varPosi, 1) - 1) \ 2, 1)

    '*基本線データ作成

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

        sngBase(Ip \ 2, 0) = CSng(varPosi(Ip + 0) * KOJITEVA  _

                                                                       + KOJITEVB)

        sngBase(Ip \ 2, 1) = CSng(varPosi(Ip + 1) * KOJITEVA _

                                                                       + KOJITEVB)

    Next Ip

    '

    '

    lngColr(0) = RGB(154, 205, 50) '←塗りつぶし色

    lngColr(1) = vbBlue '←線色

    For Kp = 0 To KOJIROWS - 1

        For Jp = 0 To KOJICOLS - 1

            '*位置補正した線データ作成

            For Ip = LBound(sngBase, 1) To UBound(sngBase, 1)

                sngData(Ip, 0) = sngBase(Ip, 0) + KOJILEFT + _

                     (144 * KOJITEVA) * Jp

                sngData(Ip, 1) = sngBase(Ip, 1) + KOJITOPP + _

                 (Jp Mod 2) * (160 * KOJITEVA) + (320 * KOJITEVA) * Kp

            Next Ip

            '*工字描画

            With ActiveDocument.Shapes.AddPolyline(sngData)

                .Fill.Visible = msoTrue

                .Fill.ForeColor = lngColr(0)                 '←ぬりつぶし色

                .Line.Visible = msoTrue

                .Line.ForeColor = lngColr(1)               '←線色

                .Line.Weight = 2.5                             '←線の太さ

            End With

        Next Jp

    Next Kp

End Sub