AutoCAD VBA天圆地方的放样展开图

天圆地方展开图，代码如下。

Public Sub Main()
Const PI As Double = 3.1415926
On Error Resume Next
Dim pt0 As Variant, ptBase(2) As Double
pt0 = ThisDrawing.Utility.GetPoint(, vbCrLf & "请输入”天圆地方“展开图下边中点<0,0>:")
If Err Then
Err.Clear
ptBase(0) = 0: ptBase(1) = 0
Else
ptBase(0) = pt0(0): ptBase(1) = pt0(1)
End If
Dim radius As Double, height As Double, length As Double
RETRY:
radius = ThisDrawing.Utility.GetDistance(ptBase, vbCrLf & "请输入”天圆”的半径：")
height = ThisDrawing.Utility.GetDistance(ptBase, vbCrLf & "请输入“天圆地方”的高度：")
length = ThisDrawing.Utility.GetDistance(ptBase, vbCrLf & "请输入“地方”的变长：")
If radius <= 0 Or height <= 0 Or length <= 0 Then
MsgBox ("输入数据必须为正，请重新输入！")
GoTo RETRY
End If
End Sub
Dim pt1 As Variant, pt2 As Variant
pt1 = ThisDrawing.Utility.PolarPoint(ptBase, 0, -0.5 * length)
pt2 = ThisDrawing.Utility.PolarPoint(ptBase, 0, 0.5 * length)
Dim dist0 As Double
dist0 = Sqr(0.25 * length - 2 + (0.5 * length - radius) ^ 2 + length ^ 2)
Dim ang1, ang2 As Double
ang1 = Atn((Sqr(height ^ 2 + (0.5 * length - radius) ^ 2) / (0.5 * length)))
ang2 = PI - ang1
Dim dist(90) As Double, i As Integer, tmp As Double
Dim angle1(90) As Double, angle2(90) As Double
For i = 0 To 90
If i = 0 Then
dist(i) = dist0
angle1(i) = ang1
angle2(i) = ang2
Else
dist(i) = Sqr((height ^ 2 + (0.5 * length - radius * Sin(i * PI / 180)) ^ 2) + (0.5 * length - radius * Cos(i * PI / 180)) ^ 2)
tmp = (dist(i) ^ 2 + dist(i - 1) ^ 2 - (radius * PI / 180) ^ 2) / (2 * dist(i) * dist(i - 1))
Angle(i) = Angle(i - 1) + Atn(-tmp / Sqr(-tmp * tmp + 1)) + 2 * Atn(1)
angle2(i) = angle2(i - 1) - Atn(-tmp / Sqr(-tmp * tmp + 1)) - 2 * Atn(1)
End If
Next
Dim point1(721) As Double
For i = 0 To 2 * 360 + 1 Step 2
If i < 180 Then
point1(i + 180) = pt1(0) + dist(90 - i / 2) * Cos(angle1(90 - i / 2))
point1(i + 181) = pt1(1) + dist(90 - i / 2) * Sin(angle1(90 - i / 2))
ElseIf i < 360 Then
point1(i + 180) = pt2(0) + dist(i / 2 - 90) * Cos(angle2(i / 2 - 90))
point1(i + 181) = pt2(1) + dist(i / 2 - 90) * Sin(angle2(i / 2 - 90))
ElseIf i <= 540 Then
tmp = (dist(90) ^ 2 + 0.25 * length ^ 2 - height ^ 2 - (0.5 * length - radius) ^ 2) / (dist(90) * length)
Dim ang3 As Double
ang3 = angle2(90) - Atn(-tmp / aqr(-tmp * tmp + 1)) - 2 * Atn(1)
Dim pt3(2) As Double
pt3(0) = pt2(0) + length * Cos(ang3)
pt3(1) = pt2(1) + length * Sin(ang3)
point1(i + 180) = pt3(0) + dist(i / 2 - 180) * Cos(angle2(i / 2 - 180) + ang3)
point1(i + 181) = pt3(1) + dist(i / 2 - 180) * Sin(angle2(i / 2 - 180) + ang3)
Else
Dim ang4 As Double
ang4 = angle1(90) + Atn(-tmp / Sqr(-tmp * tmp + 1)) + 2 * Atn(1)
Dim pt4(2) As Double
pt4(0) = pt1(0) + length * Cos(ang4)
pt4(1) = pt1(1) + length * Sin(ang4)
point1(0) = pt4(0) + dist(0) * Cos(angle1(90) + ang4 - PI)
point1(0) = pt4(1) + dist(0) * Sin(angle1(90) + ang4 - PI)
point1(i - 540) = pt4(0) + dist(360 - i / 2) * Cos(angle1(360 - i / 2) + ang4 - PI)
point1(i - 539) = pt4(1) + dist(360 - i / 2) * Sin(angle1(360 - i / 2) + ang4 - PI)
End If
Next
Dim objPoly1 As AcadLWPolyline
Set objPoly1 = ThisDrawing.ModelSpace.AddLightWeightPolyline(point1)
Dim point2(15) As Double
point2(0) = point(0)
point2(1) = point1(1)
Dim ang5 As Double
ang5 = 2 * ang4 - PI
point2(2) = pt4(0) + 0.5 * length * Cos(ang5)
point2(3) = pt4(1) + 0.5 * length * Sin(ang5)
point2(4) = pt4(0)
point2(5) = pt4(1)
point2(6) = pt1(0)
point2(7) = pt1(1)
point2(8) = pt2(0)
point2(9) = pt2(1)
point2(10) = pt3(0)
point2(11) = pt3(1)
Dim ang6 As Double
ang6 = 2 * ang3
point2(12) = pt3(0) + 0.5 * length * Cos(ang6)
point2(13) = pt3(1) + 0.5 * length * Sin(ang6)
point(14) = point1(720)
point2(15) = point1(721)
Dim objPoly2 As AcadLWPolyline
Set objpoly = ThisDrawing.ModelSpace.AddLightWeightPolyline(point2)
ZoomExtents

代码完。