【Word VBA】ジオメトリー柄描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub ジオメトリー柄描画マクロ()

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

    Const GEOMTOPP = 100　　　'                 Ｙ

    '

    Const GEOMCOLS = 7　　      '横/描画数

    Const GEOMROWS = 4 　　　 '縦/描画数

    '

    Const GEOMPRAT = 0.75　　                    'ポリライン倍率

    Const GEOMVPIT = 34 * GEOMPRAT          '横/描画間隔

    Const GEOMHPIT = 60 * GEOMPRAT          '縦/描画間隔

    '

    Const GEOMLNCL = &H3C14DC                 '線の色(Crimson)

    Const GEOMLNWT = 1                              '線の太さ

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

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer

    '

    Dim intDxp As Integer, intDyp As Integer

    Dim varPoly As Variant, intCnt As Integer

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

    Dim sngPTri() As Single

    Dim sngRad As Single, sngSit As Single

    '

    'ポリラインデータ

    varPoly = Array(35, -20, 19, -20, 10, -5, 3, -5, 0, 0, -3, 　_

                           -5, -10, -5, -19, -20, -35, -20)

    'ポリラインデータ数

    intCnt = (UBound(varPoly, 1) - 1) \ 2

    '

    'ポリラインデータ設定

    ReDim sngPBas(intCnt, 1)

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

        sngPBas(Kp \ 2, 0) = CSng(varPoly(Kp + 0)) * GEOMPRAT

        sngPBas(Kp \ 2, 1) = CSng(varPoly(Kp + 1)) * GEOMPRAT

    Next Kp 

    '

    'ポリラインデータ設定（三角状にする）

    ReDim sngPTri(intCnt * 3, 1)

    ReDim sngPDat(intCnt * 3, 1)

    sngRad = -60 * ((4 * Atn(1)) / 180)

    For Ip = 0 To 2

        sngSit = Ip * sngRad

        Jp = Choose(Ip + 1, 0, 2, 1)

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

            sngPTri(Jp * intCnt + Kp, 0) = (sngPBas(Kp, 0) * Cos(sngSit) _

                      - sngPBas(Kp, 1) * Sin(sngSit)) * IIf(Ip = 1, 1, -1)

            sngPTri(Jp * intCnt + Kp, 1) = (sngPBas(Kp, 0) * Sin(sngSit) _

                      + sngPBas(Kp, 1) * Cos(sngSit)) * IIf(Ip = 1, 1, -1)

        Next Kp

    Next Ip

    '

    '*ジオメトリー柄描画

    intDxp = GEOMLEFT: intDyp = GEOMTOPP

    For Jp = 0 To GEOMROWS - 1

        intDyp = GEOMTOPP + GEOMHPIT * Jp

        For Ip = 0 To GEOMCOLS - 1

            intDxp = GEOMLEFT + GEOMVPIT * Ip

            'ポリライン描画位置設定

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

                sngPDat(Kp, 0) = sngPTri(Kp, 0) + intDxp

                sngPDat(Kp, 1) = sngPTri(Kp, 1) + intDyp

            Next Kp

            '*ポリライン描画

            With ActiveDocument.Shapes.AddPolyline(sngPDat)

                .Fill.Visible = msoFalse

                .Line.Visible = msoTrue

                .Line.ForeColor = GEOMLNCL '←線色

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

                '△▽△▽△▽△▽・・・

                If ((Ip + Jp) Mod 2) = 0 Then

                   .Flip msoFlipVertical

                End If

           End With

        Next Ip

    Next Jp

End Sub