[求助]：天方地圆展开

ET3425

如何展开 天方地圆的
尺寸见图

                               
登录/注册后可看大图

望各位大哥,大姐帮帮忙!
急!!

782150yhm

展开的话，找关键点 。

完了

对，抓住关键问题:)

jbgs

搞清关键形状
注意关键尺寸
～～～～～～～～～～～～～～～～～～～～～～

技巧

应用关键技巧
解决关键问题
--------＝没说

highflybird

我记得ahlzl曾经写过一个这样的程序。但今天我找不到。明天找给你看看。

2. 
   
3. Option Explicit
   
4. 
   
5. ' 程序用两条优化多段线来画展开图，也可改用一条优化多段线来画
   
6. Public Sub Main()
   
7.     Const PI As Double = 3.1415926535
   
8. 
   
9.     On Error Resume Next
   
10.     ' 得到图3.27中的J点坐标
    
11.     Dim pt0 As Variant, ptBase(2) As Double
    
12.     pt0 = ThisDrawing.Utility.GetPoint(, vbCrLf & "请输入“天圆地方”展开图下边中点 <0,0>:")
    
13.    
    
14.     If Err Then
    
15.         Err.Clear
    
16.         ptBase(0) = 0: ptBase(1) = 0
    
17.     Else
    
18.         ptBase(0) = pt0(0): ptBase(1) = pt0(1)
    
19.     End If
    
20. 
    
21.     ' 获得天圆地方实体的半径、高度和底面边长
    
22.     Dim radius As Double, height As Double, length As Double
    
23. RETRY:
    
24.     radius = ThisDrawing.Utility.GetDistance(ptBase, vbCrLf & "请输入“天圆”的半径:")
    
25.     height = ThisDrawing.Utility.GetDistance(ptBase, vbCrLf & "请输入“天圆地方”的高度:")
    
26.     length = ThisDrawing.Utility.GetDistance(ptBase, vbCrLf & "请输入“地方”的边长:")
    
27. 
    
28.     If radius <= 0 Or height <= 0 Or length <= 0 Then
    
29.         MsgBox ("输入数据必须为正，请重新输入！")
    
30.         GoTo RETRY
    
31.     End If
    
32.    
    
33.     '先画展开图中的“曲线”
    
34.    
    
35.     ' 得到图3.27中的A点
    
36.     Dim pt1 As Variant, pt2 As Variant
    
37.     pt1 = ThisDrawing.Utility.PolarPoint(ptBase, 0, -0.5 * length)
    
38.    
    
39.     ' 得到图3.27中的B点
    
40.     pt2 = ThisDrawing.Utility.PolarPoint(ptBase, 0, 0.5 * length)
    
41.    
    
42.     ' 得到图3.27中的AE、BE的长度
    
43.     Dim dist0 As Double
    
44.     dist0 = Sqr(0.25 * length ^ 2 + (0.5 * length - radius) ^ 2 + height ^ 2)
    
45.    
    
46.     ' 得到图3.27中的角EAJ，为EH段各等分点坐标的计算作准备
    
47.     Dim ang1, ang2 As Double
    
48.     ang1 = Atn((Sqr(height ^ 2 + (0.5 * length - radius) ^ 2) / (0.5 * length)))
    
49.    
    
50.     ' 角EAJ的补角，为EF段各等分点坐标的计算作准备
    
51.     ang2 = PI - ang1
    
52.    
    
53.     Dim dist(90) As Double, i As Integer, tmp As Double
    
54.     Dim angle1(90) As Double, angle2(90) As Double
    
55.     For i = 0 To 90
    
56.         If i = 0 Then       ' 初值
    
57.             dist(i) = dist0
    
58.             angle1(i) = ang1
    
59.             angle2(i) = ang2
    
60.         Else
    
61.              ' 计算与A点与EH段各等分点、B点与EF段各等分点的距离
    
62.             dist(i) = Sqr((height ^ 2 + (0.5 * length - radius * Sin(i * PI / 180)) ^ 2) _
    
63.                         + (0.5 * length - radius * Cos(i * PI / 180)) ^ 2)
    
64.             
    
65.             ' 计算与A点与EH段各等分点连线和X轴正向的夹角
    
66.             tmp = (dist(i) ^ 2 + dist(i - 1) ^ 2 - (radius * PI / 180) ^ 2) / (2 * dist(i) * dist(i - 1))
    
67.                     angle1(i) = angle1(i - 1) + Atn(-tmp / Sqr(-tmp * tmp + 1)) + 2 * Atn(1)
    
68.             
    
69.             ' 计算与B点与EF段各等分点连线和X轴正向的夹角
    
70.             angle2(i) = angle2(i - 1) - Atn(-tmp / Sqr(-tmp * tmp + 1)) - 2 * Atn(1)
    
71.         End If
    
72.     Next
    
73.    
    
74.     ' 计算组成展开图的曲线部分的各点的坐标
    
75.     Dim point1(721) As Double
    
76.     For i = 0 To 2 * 360 + 1 Step 2
    
77.         If i < 180 Then
    
78.             ' 计算EH段各等分点的坐标
    
79.             point1(i + 180) = pt1(0) + dist(90 - i / 2) * Cos(angle1(90 - i / 2))
    
80.             point1(i + 181) = pt1(1) + dist(90 - i / 2) * Sin(angle1(90 - i / 2))
    
81.             
    
82.         ElseIf i < 360 Then
    
83.             ' 计算EF段各等分点的坐标
    
84.             point1(i + 180) = pt2(0) + dist(i / 2 - 90) * Cos(angle2(i / 2 - 90))
    
85.             point1(i + 181) = pt2(1) + dist(i / 2 - 90) * Sin(angle2(i / 2 - 90))
    
86.             
    
87.         ElseIf i <= 540 Then
    
88.             ' 计算FG段各等分点的坐标
    
89.             tmp = (dist(90) ^ 2 + 0.25 * length ^ 2 - height ^ 2 - (0.5 * length - radius) ^ 2) / (dist(90) * length)
    
90.             Dim ang3 As Double
    
91.             ang3 = angle2(90) - Atn(-tmp / Sqr(-tmp * tmp + 1)) - 2 * Atn(1)
    
92.             
    
93.             Dim pt3(2) As Double
    
94.             pt3(0) = pt2(0) + length * Cos(ang3)
    
95.             pt3(1) = pt2(1) + length * Sin(ang3)
    
96.             
    
97.             point1(i + 180) = pt3(0) + dist(i / 2 - 180) * Cos(angle2(i / 2 - 180) + ang3)
    
98.             point1(i + 181) = pt3(1) + dist(i / 2 - 180) * Sin(angle2(i / 2 - 180) + ang3)
    
99.            
    
100.          Else
     
101.             ' 计算HG段各等分点的坐标
     
102.             Dim ang4 As Double
     
103.             ang4 = angle1(90) + Atn(-tmp / Sqr(-tmp * tmp + 1)) + 2 * Atn(1)
     
104.             
     
105.             Dim pt4(2) As Double
     
106.             pt4(0) = pt1(0) + length * Cos(ang4)
     
107.             pt4(1) = pt1(1) + length * Sin(ang4)
     
108.             
     
109.             point1(0) = pt4(0) + dist(0) * Cos(angle1(90) + ang4 - PI)
     
110.             point1(1) = pt4(1) + dist(0) * Sin(angle1(90) + ang4 - PI)
     
111.    
     
112.             point1(i - 540) = pt4(0) + dist(360 - i / 2) * Cos(angle1(360 - i / 2) + ang4 - PI)
     
113.             point1(i - 539) = pt4(1) + dist(360 - i / 2) * Sin(angle1(360 - i / 2) + ang4 - PI)
     
114.         End If
     
115.     Next
     
116.    
     
117.     Dim objPoly1 As AcadLWPolyline
     
118.     Set objPoly1 = ThisDrawing.ModelSpace.AddLightWeightPolyline(point1)
     
119.    
     
120.     ' 再画展开图中的“折线”
     
121.     Dim point2(15) As Double
     
122.     point2(0) = point1(0)
     
123.     point2(1) = point1(1)
     
124.    
     
125.     Dim ang5 As Double
     
126.     ang5 = 2 * ang4 - PI
     
127.     point2(2) = pt4(0) + 0.5 * length * Cos(ang5)
     
128.     point2(3) = pt4(1) + 0.5 * length * Sin(ang5)
     
129.    
     
130.     point2(4) = pt4(0)
     
131.     point2(5) = pt4(1)
     
132.     point2(6) = pt1(0)
     
133.     point2(7) = pt1(1)
     
134.     point2(8) = pt2(0)
     
135.     point2(9) = pt2(1)
     
136.     point2(10) = pt3(0)
     
137.     point2(11) = pt3(1)
     
138.    
     
139.     Dim ang6 As Double
     
140.     ang6 = 2 * ang3
     
141.     point2(12) = pt3(0) + 0.5 * length * Cos(ang6)
     
142.     point2(13) = pt3(1) + 0.5 * length * Sin(ang6)
     
143.    
     
144.     point2(14) = point1(720)
     
145.     point2(15) = point1(721)
     
146.    
     
147.     Dim objPoly2 As AcadLWPolyline
     
148.     Set objPoly2 = ThisDrawing.ModelSpace.AddLightWeightPolyline(point2)
     
149.     ZoomExtents
     
150. End Sub
     

<br /> Option Explicit<br /> <br /> ' 程序用两条优化多段线来画展开图，也可改用一条优化多段线来画<br /> Public Sub Main()<br />     Const PI As Double = 3.1415926535<br /> <br />     On Error Resume Next<br />     ' 得到图3.27中的J点坐标<br />     Dim pt0 As Variant, ptBase(2) As Double<br />     pt0 = ThisDrawing.Utility.GetPoint(, vbCrLf & "请输入“天圆地方”展开图下边中点 <0,0>:")<br />     <br />     If Err Then<br />         Err.Clear<br />         ptBase(0) = 0: ptBase(1) = 0<br />     Else<br />         ptBase(0) = pt0(0): ptBase(1) = pt0(1)<br />     End If<br /> <br />     ' 获得天圆地方实体的半径、高度和底面边长<br />     Dim radius As Double, height As Double, length As Double<br /> RETRY:<br />     radius = ThisDrawing.Utility.GetDistance(ptBase, vbCrLf & "请输入“天圆”的半径:")<br />     height = ThisDrawing.Utility.GetDistance(ptBase, vbCrLf & "请输入“天圆地方”的高度:")<br />     length = ThisDrawing.Utility.GetDistance(ptBase, vbCrLf & "请输入“地方”的边长:")<br /> <br />     If radius <= 0 Or height <= 0 Or length <= 0 Then<br />         MsgBox ("输入数据必须为正，请重新输入！")<br />         GoTo RETRY<br />     End If<br />     <br />     '先画展开图中的“曲线”<br />     <br />     ' 得到图3.27中的A点<br />     Dim pt1 As Variant, pt2 As Variant<br />     pt1 = ThisDrawing.Utility.PolarPoint(ptBase, 0, -0.5 * length)<br />     <br />     ' 得到图3.27中的B点<br />     pt2 = ThisDrawing.Utility.PolarPoint(ptBase, 0, 0.5 * length)<br />     <br />     ' 得到图3.27中的AE、BE的长度<br />     Dim dist0 As Double<br />     dist0 = Sqr(0.25 * length ^ 2 + (0.5 * length - radius) ^ 2 + height ^ 2)<br />     <br />     ' 得到图3.27中的角EAJ，为EH段各等分点坐标的计算作准备<br />     Dim ang1, ang2 As Double<br />     ang1 = Atn((Sqr(height ^ 2 + (0.5 * length - radius) ^ 2) / (0.5 * length)))<br />     <br />     ' 角EAJ的补角，为EF段各等分点坐标的计算作准备<br />     ang2 = PI - ang1<br />     <br />     Dim dist(90) As Double, i As Integer, tmp As Double<br />     Dim angle1(90) As Double, angle2(90) As Double<br />     For i = 0 To 90<br />         If i = 0 Then       ' 初值<br />             dist(i) = dist0<br />             angle1(i) = ang1<br />             angle2(i) = ang2<br />         Else<br />              ' 计算与A点与EH段各等分点、B点与EF段各等分点的距离<br />             dist(i) = Sqr((height ^ 2 + (0.5 * length - radius * Sin(i * PI / 180)) ^ 2) _<br />                         + (0.5 * length - radius * Cos(i * PI / 180)) ^ 2)<br />             <br />             ' 计算与A点与EH段各等分点连线和X轴正向的夹角<br />             tmp = (dist(i) ^ 2 + dist(i - 1) ^ 2 - (radius * PI / 180) ^ 2) / (2 * dist(i) * dist(i - 1))<br />                     angle1(i) = angle1(i - 1) + Atn(-tmp / Sqr(-tmp * tmp + 1)) + 2 * Atn(1)<br />             <br />             ' 计算与B点与EF段各等分点连线和X轴正向的夹角<br />             angle2(i) = angle2(i - 1) - Atn(-tmp / Sqr(-tmp * tmp + 1)) - 2 * Atn(1)<br />         End If<br />     Next<br />     <br />     ' 计算组成展开图的曲线部分的各点的坐标<br />     Dim point1(721) As Double<br />     For i = 0 To 2 * 360 + 1 Step 2<br />         If i < 180 Then<br />             ' 计算EH段各等分点的坐标<br />             point1(i + 180) = pt1(0) + dist(90 - i / 2) * Cos(angle1(90 - i / 2))<br />             point1(i + 181) = pt1(1) + dist(90 - i / 2) * Sin(angle1(90 - i / 2))<br />             <br />         ElseIf i < 360 Then<br />             ' 计算EF段各等分点的坐标<br />             point1(i + 180) = pt2(0) + dist(i / 2 - 90) * Cos(angle2(i / 2 - 90))<br />             point1(i + 181) = pt2(1) + dist(i / 2 - 90) * Sin(angle2(i / 2 - 90))<br />             <br />         ElseIf i <= 540 Then<br />             ' 计算FG段各等分点的坐标<br />             tmp = (dist(90) ^ 2 + 0.25 * length ^ 2 - height ^ 2 - (0.5 * length - radius) ^ 2) / (dist(90) * length)<br />             Dim ang3 As Double<br />             ang3 = angle2(90) - Atn(-tmp / Sqr(-tmp * tmp + 1)) - 2 * Atn(1)<br />             <br />             Dim pt3(2) As Double<br />             pt3(0) = pt2(0) + length * Cos(ang3)<br />             pt3(1) = pt2(1) + length * Sin(ang3)<br />             <br />             point1(i + 180) = pt3(0) + dist(i / 2 - 180) * Cos(angle2(i / 2 - 180) + ang3)<br />             point1(i + 181) = pt3(1) + dist(i / 2 - 180) * Sin(angle2(i / 2 - 180) + ang3)<br />            <br />          Else<br />             ' 计算HG段各等分点的坐标<br />             Dim ang4 As Double<br />             ang4 = angle1(90) + Atn(-tmp / Sqr(-tmp * tmp + 1)) + 2 * Atn(1)<br />             <br />             Dim pt4(2) As Double<br />             pt4(0) = pt1(0) + length * Cos(ang4)<br />             pt4(1) = pt1(1) + length * Sin(ang4)<br />             <br />             point1(0) = pt4(0) + dist(0) * Cos(angle1(90) + ang4 - PI)<br />             point1(1) = pt4(1) + dist(0) * Sin(angle1(90) + ang4 - PI)<br />     <br />             point1(i - 540) = pt4(0) + dist(360 - i / 2) * Cos(angle1(360 - i / 2) + ang4 - PI)<br />             point1(i - 539) = pt4(1) + dist(360 - i / 2) * Sin(angle1(360 - i / 2) + ang4 - PI)<br />         End If<br />     Next<br />     <br />     Dim objPoly1 As AcadLWPolyline<br />     Set objPoly1 = ThisDrawing.ModelSpace.AddLightWeightPolyline(point1)<br />     <br />     ' 再画展开图中的“折线”<br />     Dim point2(15) As Double<br />     point2(0) = point1(0)<br />     point2(1) = point1(1)<br />     <br />     Dim ang5 As Double<br />     ang5 = 2 * ang4 - PI<br />     point2(2) = pt4(0) + 0.5 * length * Cos(ang5)<br />     point2(3) = pt4(1) + 0.5 * length * Sin(ang5)<br />     <br />     point2(4) = pt4(0)<br />     point2(5) = pt4(1)<br />     point2(6) = pt1(0)<br />     point2(7) = pt1(1)<br />     point2(8) = pt2(0)<br />     point2(9) = pt2(1)<br />     point2(10) = pt3(0)<br />     point2(11) = pt3(1)<br />     <br />     Dim ang6 As Double<br />     ang6 = 2 * ang3<br />     point2(12) = pt3(0) + 0.5 * length * Cos(ang6)<br />     point2(13) = pt3(1) + 0.5 * length * Sin(ang6)<br />     <br />     point2(14) = point1(720)<br />     point2(15) = point1(721)<br />     <br />     Dim objPoly2 As AcadLWPolyline<br />     Set objPoly2 = ThisDrawing.ModelSpace.AddLightWeightPolyline(point2)<br />     ZoomExtents<br /> End Sub<br />

这是源代码，alt+F8运行，按照提示即可，原来例子是天圆地方，你要的是天方地圆，也许不用我提示，你也能想象是怎么做了。