Option Explicit
Option Base 0
'
Public Sub ベジェ曲線による蜘蛛の巣描画マクロ()
Const SPICXPOS = 220 '蜘蛛の巣の中心位置 X
Const SPICYPOS = 200 ' Y
Const SPICCRAD = 150 '蜘蛛の巣の半径
Const SPILCONT = 10 '線の数
Const SPINCONT = 6 '横線の数
Const SPILNWEI = 1.5 '線の太さ
Const SPISAGGI = 0.9 'たるみ度
'---------------------------------------------------------------------------
Dim Ip As Integer, Jp As Integer, intAng As Integer, dblRd As Double
Dim intNR As Integer, lngCl As Long
Dim intXp1 As Integer, intYp1 As Integer
Dim sngWrk(3, 1) As Single, sngRad(1) As Single
'
lngCl = vbBlack
dblRd = (4 * Atn(1)) / 180: intAng = 360 \ SPILCONT
intNR = SPICCRAD \ SPINCONT
For Ip = 0 To SPILCONT - 1
intXp1 = SPICCRAD * Cos(dblRd * (intAng * Ip)) + SPICXPOS
intYp1 = SPICCRAD * Sin(dblRd * (intAng * Ip)) + SPICYPOS
With ActiveDocument.Shapes.AddLine(intXp1, intYp1, _
SPICXPOS, SPICYPOS).Line
.ForeColor.RGB = lngCl '←線色
.Weight = SPILNWEI '←線の太さ
End With
For Jp = 1 To SPINCONT - 1
sngRad(0) = intNR * Jp
sngRad(1) = sngRad(0) * SPISAGGI
'
sngWrk(0, 0) = sngRad(0) * Cos(dblRd * (intAng * Ip)) _
+ SPICXPOS
sngWrk(0, 1) = sngRad(0) * Sin(dblRd * (intAng * Ip)) _
+ SPICYPOS
sngWrk(1, 0) = sngRad(1) * Cos(dblRd * ((intAng * Ip) _
+ intAng * (1 / 3))) + SPICXPOS
sngWrk(1, 1) = sngRad(1) * Sin(dblRd * ((intAng * Ip) _
+ intAng * (1 / 3))) + SPICYPOS
sngWrk(2, 0) = sngRad(1) * Cos(dblRd * ((intAng * Ip) _
+ intAng * (2 / 3))) + SPICXPOS
sngWrk(2, 1) = sngRad(1) * Sin(dblRd * ((intAng * Ip) _
+ intAng * (2 / 3))) + SPICYPOS
sngWrk(3, 0) = sngRad(0) * Cos(dblRd * (intAng * _
(Ip + 1))) + SPICXPOS
sngWrk(3, 1) = sngRad(0) * Sin(dblRd * (intAng * _
(Ip + 1))) + SPICYPOS
With ActiveDocument.Shapes.AddCurve(sngWrk)
.Line.ForeColor.RGB = lngCl '←線色
.Line.Weight = SPILNWEI '←線の太さ
End With
Next Jp
Next Ip
End Sub
Public Sub 直線だけによる蜘蛛の巣描画マクロ()
Const SPICXPOS = 220 '蜘蛛の巣の中心位置 X
Const SPICYPOS = 200 ' Y
Const SPICCRAD = 150 '蜘蛛の巣の半径
Const SPILCONT = 10 '線の数
Const SPINCONT = 6 '横線の数
Const SPILNWEI = 1.5 '線の太さ
'---------------------------------------------------------------------------
Dim Ip As Integer, Jp As Integer, intAng As Integer, dblRd As Double
Dim intXp1 As Integer, intYp1 As Integer
Dim intXp2 As Integer, intYp2 As Integer
Dim intNR As Integer, lngCl As Long
'
dblRd = (4 * Atn(1)) / 180: intAng = 360 \ SPILCONT
intNR = SPICCRAD \ SPINCONT
lngCl = vbBlue
For Ip = 0 To SPILCONT - 1
intXp1 = SPICCRAD * Cos(dblRd * (intAng * Ip)) + SPICXPOS
intYp1 = SPICCRAD * Sin(dblRd * (intAng * Ip)) + SPICYPOS
With ActiveDocument.Shapes.AddLine(intXp1, intYp1, _
SPICXPOS, SPICYPOS).Line
.ForeColor.RGB = lngCl '←線色
.Weight = SPILNWEI '←線の太さ
End With
For Jp = 1 To SPINCONT - 1
intXp1 = intNR * Jp * Cos(dblRd * (intAng * Ip)) _
+ SPICXPOS
intYp1 = intNR * Jp * Sin(dblRd * (intAng * Ip)) _
+ SPICYPOS
intXp2 = intNR * Jp * Cos(dblRd * (intAng * _
(Ip + 1))) + SPICXPOS
intYp2 = intNR * Jp * Sin(dblRd * (intAng * _
(Ip + 1))) + SPICYPOS
With ActiveDocument.Shapes.AddLine(intXp1, intYp1, _
intXp2, intYp2).Line
.ForeColor.RGB = lngCl '←線色
.Weight = SPILNWEI '←線の太さ
End With
Next Jp
Next Ip
End Sub
