Public Sub 渦巻描画マクロ()
Const SWIRCXPS = 200 '描画の中心位置 X
Const SWIRCYPS = 200 ' Y
Const SWIRSRAD = 20 '開始半径
Const SWIRRECT = 5 '中心点のズレ
Const SWIRCONT = 3 '巻き数
'---------------------------------------------------------------------------
Dim Ip As Integer, Jp As Integer
Dim intCxp As Integer, intCyp As Integer, intRad As Integer
Dim intSxp As Integer, intSyp As Integer
Dim sngAng As Single
'
intRad = SWIRSRAD: sngAng = 0
For Ip = 0 To SWIRCONT * 4 - 1
Jp = Ip Mod 4
intCxp = SWIRCXPS + SWIRRECT * Choose(Jp + 1, -1, -1, 1, 1)
intCyp = SWIRCYPS + SWIRRECT * Choose(Jp + 1, 1, -1, -1, 1)
If Ip > 0 And (Ip Mod 4) = 0 Then intRad = intRad _
+ SWIRRECT * 4
Select Case Jp
Case 0:
intSxp = SWIRCXPS _
- intRad * Cos(sngAng * m_dblRad) + SWIRRECT
intSyp = SWIRCYPS
Case 1:
intSxp = SWIRCXPS:
intSyp = SWIRCYPS _
+ intRad * Cos(sngAng * m_dblRad) + SWIRRECT
Case 2:
intSxp = SWIRCXPS _
- intRad * Cos(sngAng * m_dblRad) - SWIRRECT
intSyp = SWIRCYPS
Case 3:
intSxp = SWIRCXPS
intSyp = SWIRCYPS _
- intRad * Cos(sngAng * m_dblRad) - SWIRRECT
End Select
'
intRad = CInt(Sqr((intSxp - intCxp) ^ 2 + _
(intSyp - intCyp) ^ 2))
'
sngAng = Atn(Abs(intSxp - intCxp) / _
Abs(intSyp - intCyp)) / (4 * Atn(1)) * 180
If Jp = 0 Or Jp = 2 Then
sngAng = 90 - sngAng
End If
With ActiveDocument.Shapes.AddShape(msoShapeArc, _
intCxp - intRad, intCyp - intRad, _
intRad * 2, intRad * 2)
.Fill.Visible = False
.Line.ForeColor.RGB = vbBlue '←線色
.Line.Weight = 1.5 '←線の太さ
.Adjustments(1) = ((Jp * 90) Mod 360) - sngAng
.Adjustments(2) = (((Jp * 90) + 90) Mod 360) - sngAng
End With
Next Ip
End Sub
Const SWIRCONT = 1 '巻き数
Const SWIRCONT = 2 '巻き数
蛇足
自分のＨＰにも 渦巻描画マクロを載せているけど、それは、関数を使って線描画していますが、このマクロは、中心をずらした円弧を合わせて描いています。
