毕业论文源码共享---过点向曲线做直线

matrix

本人思路如下，选定一点和一个曲线，然后随便定义一个线长度，以线长和选定点，循环角度画直线，然后求直线与曲线的交点，再删除原直线，以选定点和交点为直线的两端重新画直线，累了很长时间才搞定的，刚学VBA，欢迎大家提意见啊，

2. Dim angle As Double
3. Dim p1 As Variant '定义起始点
4. Dim p2(0 To 2) As Double '定义末点
5. Dim p5(0 To 2) As Double '定义变点
6. Dim lineObj As AcadLine '定义直线
7. Dim lineobj2 As AcadLine '定义重新画的直线
8. Dim curveobj As AcadObject '定义选择曲线
9. Dim intersectpoint As Variant '定义交点
10. frmprogramme.Hide
11. p1 = ThisDrawing.Utility.GetPoint(, "选取坝体上某一点")
12. ThisDrawing.Utility.GetEntity curveobj, pickedpoint, "请选定曲线"
13. For angle = 180 To 360 Step 5 '开始按角度循环
14. Dim realangle As Double
15. realangle = ThisDrawing.Utility.AngleToReal(angle, acDegreeMinuteSeconds) '角度由弧度转换为角度
16. p2(0) = p1(0) + 100 * Cos(realangle)
17. p2(1) = p1(1) + 100 * Sin(realangle)
18. p2(2) = p1(2)
19. Set lineObj = ThisDrawing.ModelSpace.addline(p1, p2) '初始画线
20. intersectpoint = lineObj.IntersectWith(curveobj, acExtendThisEntity) '得到交点
21. If UBound(intersectpoint) <> -1 Then '去除空点
22. p5(0) = intersectpoint(0): p5(1) = intersectpoint(1): p5(2) = 0 '定义重新画线的端点
23. Set lineobj2 = ThisDrawing.ModelSpace.addline(p1, p5) '重新画线
24. lineobj2.color = Int(255 * Rnd + 1) '定义直线颜色为随机颜色
25. lineobj2.Highlight True '亮显直线
26. lineobj2.Update '更新直线
27. End If
28. lineObj.Delete '删除原直线
29. Next angle '重新开始下一个循环
30. frmprogramme.Show

Dim angle As Double Dim p1 As Variant '定义起始点 Dim p2(0 To 2) As Double '定义末点 Dim p5(0 To 2) As Double '定义变点 Dim lineObj As AcadLine '定义直线 Dim lineobj2 As AcadLine '定义重新画的直线 Dim curveobj As AcadObject '定义选择曲线 Dim intersectpoint As Variant '定义交点 frmprogramme.Hide p1 = ThisDrawing.Utility.GetPoint(, "选取坝体上某一点") ThisDrawing.Utility.GetEntity curveobj, pickedpoint, "请选定曲线" For angle = 180 To 360 Step 5 '开始按角度循环 Dim realangle As Double realangle = ThisDrawing.Utility.AngleToReal(angle, acDegreeMinuteSeconds) '角度由弧度转换为角度 p2(0) = p1(0) + 100 * Cos(realangle) p2(1) = p1(1) + 100 * Sin(realangle) p2(2) = p1(2) Set lineObj = ThisDrawing.ModelSpace.addline(p1, p2) '初始画线 intersectpoint = lineObj.IntersectWith(curveobj, acExtendThisEntity) '得到交点 If UBound(intersectpoint) <> -1 Then '去除空点 p5(0) = intersectpoint(0): p5(1) = intersectpoint(1): p5(2) = 0 '定义重新画线的端点 Set lineobj2 = ThisDrawing.ModelSpace.addline(p1, p5) '重新画线 lineobj2.color = Int(255 * Rnd + 1) '定义直线颜色为随机颜色 lineobj2.Highlight True '亮显直线 lineobj2.Update '更新直线 End If lineObj.Delete '删除原直线 Next angle '重新开始下一个循环 frmprogramme.Show

另外，如果哪位兄弟会标高的话，请随后跟贴，我还有一步是做选定直线上一点，返回直线的标高，并根据这个标高，选择相同标高的一个曲线，如果有高手的话，请教一下啊

pslstar

好东西啊，谢谢分享