【Word VBA】リサジュ―曲線模様描画マクロ▽ソースコード
記事IT・テクノロジー
Option Explicit
Option Base 0
'
Public Sub リサジュ―曲線模様描画マクロ()
Const LISSLEFT = 80 '描画開始位置Ｘ
Const LISSTOPP = 80 ' Ｙ
'
Const LISSCOLS = 6 '横/描画数
Const LISSROWS = 5 '縦/描画数
'
Const LISSANSP = 5 '描画刻み角度
Const LISSRATE = 20 '線の長さレート
'
Const LISSCASE = 4 'リサージュの種類
Const LISSVPIT = LISSRATE * 2.25 '横/描画間隔
Const LISSHPIT = LISSRATE * 2.25 '縦/描画間隔
'
Const LISSLNWE = 1.5 '線の太さ
'---------------------------------------------------------------------------
Dim Ip As Integer, Jp As Integer
Dim Kp As Integer, Lp As Integer
Dim intDxp As Integer, intDyp As Integer
Dim sngPBas(LISSCASE - 1, 360 / LISSANSP, 1) As Single
Dim sngPDat(360 / LISSANSP, 1) As Single
Dim sngSit As Single, sngRpd As Single
Dim sngRds As Single
'
'リサージュ曲線のポリラインデータ作成
'x=sin(n*θ)/ y=sin(m*θ)
sngRpd = Atn(1) / 45
For Lp = 0 To UBound(sngPBas, 1)
For Kp = 0 To UBound(sngPBas, 2)
sngSit = sngRpd * (Kp * LISSANSP)
Ip = Choose(Lp + 1, 2, 3, 5, 7)
Jp = Choose(Lp + 1, 3, 4, 4, 8)
sngPBas(Lp, Kp, 0) = Sin(Ip * sngSit) * LISSRATE
sngPBas(Lp, Kp, 1) = Sin(Jp * sngSit) * LISSRATE
Next Kp
Next Lp
'
Lp = 0
For Jp = 0 To LISSROWS - 1
intDyp = LISSTOPP + LISSHPIT * Jp _
+ LISSHPIT / 2
For Ip = 0 To LISSCOLS - 1
intDxp = LISSLEFT + LISSVPIT * Ip _
+ LISSVPIT / 2
'*ポリラインデータ位置設定
For Kp = 0 To UBound(sngPBas, 2)
sngPDat(Kp, 0) = _
sngPBas(Lp Mod LISSCASE, Kp, 0) _
+ intDxp
sngPDat(Kp, 1) = _
sngPBas(Lp Mod LISSCASE, Kp, 1) _
+ intDyp
Next Kp
'*ポリラインデータ描画
With ActiveDocument.Shapes.AddPolyline(sngPDat)
.Fill.Visible = msoFalse
.Line.Visible = msoTrue
.Line.ForeColor = _
Choose((Lp Mod LISSCASE) + 1, _
RGB(218, 165, 32), RGB(0, 100, 0), _
RGB(0, 128, 128), RGB(106, 90, 205)) '←線色
.Line.Weight = LISSLNWE '←線の太さ
End With
Lp = Lp + 1
Next Ip
Next Jp
End Sub
