【Word VBA】らせん模様描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub らせん模様描画マクロ()

    Const SPIRPAIV = 3.141592

    Const SPIRRADI = (SPIRPAIV / 180)

    '

    Const SPIRLEFT = 80                   '描画開始位置Ｘ

    Const SPIRTOPP = 90          　     '　　　　　　Ｙ

    '

    Const SPIRVPIT = 50 　　　　　　'横-間隔

    Const SPIRHPIT = 55　　　         '縦-間隔

    Const SPIRCOLS = 5 　　　　　　'横/描画数

    Const SPIRROWS = 4 　　　　　  '縦/描画数

    '

    Const SPIRRDUS = 15 　　　　　'らせん半径

    Const SPIRPICH = 10　　　        'らせんピッチ

    Const SPIRCONT = 360 　　　　 '描画点数

    Const SPIRDANG = 5                 '角度間隔

    '

    Const SPIRTRNX = 45 * SPIRRADI       '三次元描画角度

    Const SPIRTRNY = -30 * SPIRRADI

    Const SPIRTRNZ = 0

    Const SPIRLNWE = 1                 '線の太さ

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

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer

    Dim intDxp As Integer, intDyp As Integer

    Dim sngPxp As Single, sngPyp As Single

    Dim sngAng As Single

    Dim sngPDat(SPIRCONT, 1) As Single

    Dim varLnCl As Variant

    '

    '*線色定義

    varLnCl = Array(&HE7D00E2, &H5AFF, &HE89F00)

    For Jp = 0 To SPIRROWS - 1

        intDyp = SPIRTOPP + SPIRHPIT * Jp

        For Ip = 0 To SPIRCOLS - 1

            intDxp = SPIRLEFT + SPIRVPIT * Ip

            '

            '*ポリラインデータ作成

            For Kp = 0 To SPIRCONT

                sngAng = SPIRRADI * Kp * SPIRDANG

                Call 三次元回転変換(SPIRRDUS * Cos(sngAng), _

                                    SPIRRDUS * Sin(sngAng), _

                  SPIRPICH * ((Kp * SPIRDANG) / 360#) * -1, _

                  SPIRTRNX, SPIRTRNY, SPIRTRNZ, sngPxp, sngPyp)

               sngPDat(Kp, 0) = sngPxp + CSng(intDxp)

               sngPDat(Kp, 1) = sngPyp + CSng(intDyp)

            Next Kp

            '*らせんのポリライン描画

            With ActiveDocument.Shapes.AddPolyline(sngPDat)

                .Fill.Visible = msoFalse

                .Line.Visible = msoTrue

                .Line.ForeColor = _

              varLnCl((Jp * SPIRCOLS + Ip) Mod 3)　　　 '←線色

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

            End With

        Next Ip

    Next Jp

End Sub

'******************************************************

Public Sub 三次元回転変換(psngXpt As Single, psngYpt As Single, _

       psngZpt As Single, psngXan As Single, psngYan As Single, _

       psngZan As Single, _

       ByRef rPntXpt As Single, ByRef rPntYpt As Single)

    '

    Dim sngX1 As Single, sngY1 As Single, sngZ1 As Single

    Dim sngX2 As Single, sngY2 As Single

    '

    sngX1 = psngXpt * Cos(psngYan) + psngZpt * Sin(psngYan)

    sngY1 = psngYpt

    sngZ1 = -1 * psngXpt * Sin(psngYan) + psngZpt * Cos(psngYan)

    sngX2 = sngX1

    sngY2 = sngY1 * Cos(psngXan) - sngZ1 * Sin(psngXan)

    '

    rPntXpt = sngX2 * Cos(psngZan) - sngY2 * Sin(psngZan)

    rPntYpt = sngX2 * Sin(psngZan) + sngY2 * Cos(psngZan)

End Sub