【Word VBA】アルキメデスの螺旋描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub アルキメデスの螺旋描画マクロ()

    Const ARUKPAIV = 3.141592653589 　　'π

    Const ARUKRADI = ARUKPAIV / 180　     'π/180

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

    Const ARUKTOPP = 100　　　　　　　　   '　　　　　　Ｙ

    '

    Const ARUKVPIT = 30                             '横-間隔

    Const ARUKHPIT = 30                             '縦-間隔

    Const ARUKCOLS = 8                              '横/描画数

    Const ARUKROWS = 5                            '縦/描画数

    '

    Const ARUKEANG = 360 * 5                    '終点角度(°)

    Const ARUKAVAL = 0.5                           '係数Ａ(サイズ)

   '

    Const ARUKLNWT = 1.5                          '線の太さ

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

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer, Lp As Integer

    Dim intDxp As Integer, intDyp As Integer

    Dim sngPlp(ARUKEANG, 1) As Single

    Dim sngSit As Single, sngRad As Single

    '

    Lp = 0

    For Jp = 0 To ARUKROWS - 1

        intDyp = ARUKTOPP + ARUKHPIT * Jp

        For Ip = 0 To ARUKCOLS - 1

            intDxp = ARUKLEFT + ARUKVPIT * Ip

            '

            '*座標を算出、ポリラインの配列に格納

            For Kp = 0 To ARUKEANG

                sngSit = ARUKRADI * Kp

                sngRad = ARUKAVAL * sngSit

                sngPlp(Kp, 0) = sngRad * Cos(sngSit) + intDxp

                sngPlp(Kp, 1) = sngRad * Sin(sngSit) + intDyp

            Next Kp

            '

            '*ポリライン描画

            With ActiveDocument.Shapes.AddPolyline(sngPlp)

                .Fill.Visible = msoFalse

                .Line.Visible = msoCTrue

                .Line.ForeColor = QBColor(Lp Mod 14)          '←線色

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

                .Line.DashStyle = msoLineSolid                    '←線種

            End With

            Lp = Lp + 1

        Next Ip

    Next Jp

End Sub