【Word VBA】松皮菱文様描画マクロ▽ソースコード

Option Explicit

Option Base 0

Public Sub 松皮菱文様描画マクロ()

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

    Const PIBATOPP = 100　　'　　　　　　Ｙ

    '

    Const PIBASIZE = 1# 　　 'ポリライン設定倍率

    '

    Const PIBACOLS = 3 　　  '横描画数

    Const PIBAROWS = 5 　　 '縦描画数

    '

    Const PIBAWDSP = 24 　　'横方向間隔

    Const PIBAHTSP = 4 　　   '縦方向間隔

    '

    Const PIBALNWE = 3 　　  '線の太さ

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

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

    Dim intCxp As Integer, intCyp As Integer

    Dim intCwd As Integer, intCht As Integer

    Dim varPoly As Variant

    Dim sngPBas() As Single, sngPDat() As Single

    Dim sngLmt(3) As Single, lngCol As Long

    '

    '*ポリラインデータ

    varPoly = Array(-26#, 0#, -10.4, -7.4, -15.6, -11.1, 0#, -18.3, _

                               0#, -18.3, _

    15.6, -11.1, 10.4, -7.4, 26#, 0#, 26#, 0#, 10.4, 7.4, 15.6, 11.1, _

                               0#, 18.3, _

    0#, 18.3, -15.6, 11.1, -10.4, 7.4, -26#, 0#)

    '*ポリラインデータ設定

    ReDim sngPBas((UBound(varPoly, 1) - 1) \ 2, 1)

    ReDim sngPDat((UBound(varPoly, 1) - 1) \ 2, 1)

    sngLmt(0) = 9999: sngLmt(1) = 9999:

    sngLmt(2) = -9999: sngLmt(3) = -9999

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

        sngPBas(Ip \ 2, 0) = CSng(varPoly(Ip + 0)) * PIBASIZE

        sngPBas(Ip \ 2, 1) = CSng(varPoly(Ip + 1)) * PIBASIZE

  　　'ポリラインデータ範囲取得

       If sngLmt(0) > sngPBas(Ip \ 2, 0) Then _

                              sngLmt(0) = sngPBas(Ip \ 2, 0)

        If sngLmt(1) > sngPBas(Ip \ 2, 1) Then _

                               sngLmt(1) = sngPBas(Ip \ 2, 1)

        If sngLmt(2) < sngPBas(Ip \ 2, 0) Then _

                               sngLmt(2) = sngPBas(Ip \ 2, 0)

        If sngLmt(3) < sngPBas(Ip \ 2, 1) Then _

                               sngLmt(3) = sngPBas(Ip \ 2, 1)

    Next Ip

    '

    lngCol = RGB(184, 134, 11) 　　'←線色

    intCwd = (sngLmt(2) - sngLmt(0)) + PIBAWDSP

    intCht = (sngLmt(3) - sngLmt(1)) / 2 + PIBAHTSP

    For Jp = 0 To PIBAROWS - 1

        intCyp = PIBATOPP + intCht * (Jp + 1)

        For Ip = 0 To PIBACOLS - 1

            intCxp = PIBALEFT + intCwd * Ip + (intCwd / 2) * (Jp Mod 2)

            For Kp = LBound(sngPBas, 1) To UBound(sngPBas, 1)

               sngPDat(Kp, 0) = sngPBas(Kp, 0) + intCxp

               sngPDat(Kp, 1) = sngPBas(Kp, 1) + intCyp

            Next Kp

      　　'*ポリライン描画

            With ActiveDocument.Shapes.AddPolyline(sngPDat)

                .Fill.Visible = msoFalse

                .Line.Visible = msoTrue

                .Line.ForeColor = lngCol                      '←線色

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

                .Line.Style = msoLineThickThin            '←二重線

           End With

       Next Ip

   Next Jp

End Sub