【Word VBA】四葉線模様描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub 四葉線模様描画マクロ()

    Const FOLVLEFT = 80　　　    '描画中心位置Ｘ

    Const FOLVTOPP = 80 　　　　'　　　　　　Ｙ

    '

    Const FOLVANSP = 5　　　      '描画刻み角度

    Const FOLVRATE = 8 　　　　  '線の長さレート

    '

    Const FOLVVPIT = FOLVRATE * 4    '横-間隔

    Const FOLVHPIT = FOLVRATE * 4   '縦-間隔

    Const FOLVCOLS = 7                     '横/描画数

    Const FOLVROWS = 6                    '縦/描画数

    '

    Const FOLVLNWE = 1                    '線の太さ

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

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer

    Dim intCxp As Integer, intCyp As Integer

    Dim sngPBas(360 / FOLVANSP, 1) As Single

    Dim sngPDat(360 / FOLVANSP, 1) As Single

    Dim sngSit As Single, sngRpd As Single

    Dim sngRds As Single, lngCol(1) As Long

    '

    '*四葉線曲線ポリラインデータ作成

    sngRpd = Atn(1) / 45

    For Kp = 0 To UBound(sngPBas, 1)

        sngSit = sngRpd * (Kp * FOLVANSP)

        sngRds = 1 + Cos(4 * sngSit)

        sngPBas(Kp, 0) = (sngRds * Cos(sngSit)) * FOLVRATE

        sngPBas(Kp, 1) = (sngRds * Sin(sngSit)) * FOLVRATE

    Next Kp

    '

    lngCol(0) = RGB(0, 128, 0)                 '←線色

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

    For Jp = 0 To FOLVROWS - 1

        intCyp = FOLVTOPP + FOLVHPIT * Jp _

                          + FOLVVPIT \ 2

        For Ip = 0 To FOLVCOLS - 1

            intCxp = FOLVLEFT + FOLVVPIT * Ip _

                          + FOLVHPIT \ 2

            '*ポリライン位置設定

            For Kp = 0 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 = msoTrue

                .Fill.ForeColor = lngCol(1)          '←塗りつぶし

                .Line.Visible = msoTrue

                .Line.ForeColor = lngCol(0)        '←線色

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

            End With

        Next Ip

    Next Jp

End Sub