【Word VBA】リチュース螺旋描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub リチュース螺旋描画マクロ() 

   Const LITUPAIV = 3.141592653589 　　　　'π

   Const LITURADI = LITUPAIV / 180 　　　　  'π/180

   Const LITUCXPT = 180                               '描画開始位置

   Const LITUCYPT = 170

   '

   Const LITUEANG = 360 * 3                         '終点角度(°)

   Const LITUAVAL = 75                                 '係数Ａ（size）

   Const LITULNCL = &H578B2E                     '線の色

   Const LITULNWT = 1.5                               '線の太さ

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

   Dim Ip As Integer, Jp As Integer

   Dim sngTmp(LITUEANG, 1) As Single

   Dim sngPol(LITUEANG, 1) As Single

   Dim sngSit As Single, sngRad As Single

   Dim sngSin As Single, sngCos As Single

   '

   '*テンプレートポリライン作成

   For Ip = 0 To LITUEANG

       sngSit = LITURADI * (Ip + 90)

       sngRad = LITUAVAL / Sqr(sngSit)

       sngTmp(Ip, 0) = sngRad * Cos(sngSit)

       sngTmp(Ip, 1) = sngRad * Sin(sngSit)

   Next Ip

   '*テンプレートポリラインの位置補正

   For Ip = 1 To LITUEANG

      sngTmp(Ip, 0) = sngTmp(Ip, 0) - sngTmp(0, 0)

      sngTmp(Ip, 1) = sngTmp(Ip, 1) - sngTmp(0, 1)

   Next Ip

   '*ポリライン描画

   For Jp = 0 To 3

       '*ポリラインの位置を回転＆移動

       sngSit = LITURADI * (Jp * 90)

       sngSin = Sin(sngSit)

       sngCos = Cos(sngSit)

       For Ip = 0 To LITUEANG

           sngPol(Ip, 0) = sngTmp(Ip, 0) * sngCos _

                         - sngTmp(Ip, 1) * sngSin + LITUCXPT

           sngPol(Ip, 1) = sngTmp(Ip, 1) * sngCos _

                         + sngTmp(Ip, 0) * sngSin + LITUCYPT

       Next Ip

       '*ポリライン描画

       With ActiveDocument.Shapes.AddPolyline(sngPol)

           .Fill.Visible = msoFalse

           .Line.Visible = msoCTrue

           .Line.ForeColor = LITULNCL               '←線色

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

       End With

   Next Jp

End Sub