请问如何获得图形中特定点信息??

daydayup

如上的地形等高线图中,红线表示一截面.请问怎么自动获得截面与等高线交点的数据(如坐标等).请问能够自动生成该截面的剖面图吗?


我是个初学者,请各位大侠多多指教.给点思路

雪山飞狐_lzh

你的等高线是什么，下面是我以前写的Spline等高线的剖面测试

2. Sub t9()
3. On Error GoTo ErrHandle
4. Dim ss As AcadSelectionSet
5. Dim ssLine As AcadSelectionSet
6. Dim ft(0) As Integer, fd(0)
7. Dim p1(2) As Double, p2(2) As Double
8. Dim pPnts()
9. Dim pLine As AcadLine, dot
10. Dim i, j
11. Dim pInsertPnt
12. Dim pInsertPnts()
13. Dim pNum As Integer
14. Dim pnt(2) As DoubleDim pStart, PEnd
15. Dim pCount As Integer
16. Dim pDistances() As Double
17. Set ss = ThisDrawing.SelectionSets.Add("*TlsTest*")
18. ft(0) = 0: fd(0) = "Spline"
19. ss.Select acSelectionSetAll, , , ft, fd
20. ReDim pPnts(ss.Count - 1)
21. For i = 0 To ss.Count - 1
22. pPnts(i) = ss(i).ControlPoints
23. p1(2) = pPnts(i)(2)
24. ss(i).Move p1, p2
25. Next i
26. Set ssLine = ThisDrawing.SelectionSets.Add("*TlsTestLine*")
27. ft(0) = 0: fd(0) = "Line"ssLine.Select acSelectionSetAll, , , ft, fd
28. For Each pLine In ssLine
29. pNum = 0
30. For i = 0 To ss.Count - 1
31. pInsertPnt = pLine.IntersectWith(ss(i), acExtendNone)
32. n = (UBound(pInsertPnt) + 1) / 3
33. For j = 0 To n - 1
34. pnt(0) = pInsertPnt(j * 3)
35. pnt(1) = pInsertPnt(j * 3 + 1)
36. pnt(2) = pPnts(i)(2)
37. ReDim Preserve pInsertPnts(pNum)
38. pInsertPnts(pNum) = pnt
39. pNum = pNum + 1
40. Next j
41. Next ipStart = pLine.StartPoint
42. PEnd = pLine.EndPoint
43. pCount = UBound(pInsertPnts)If Abs(Tan(pLine.Angle)) < 1 Then pNum = 0 Else pNum = 1ReDim pDistances(pCount) As Double
44. For i = 0 To pCount
45. pDistances(i) = Abs(pInsertPnts(i)(pNum) - pStart(pNum))
46. Next i
47. SortPoint pDistances, pInsertPnts, pCount
48. Dim pDPnts() As Double
49. pNum = UBound(pInsertPnts) * 3 + 2
50. ReDim pDPnts(pNum) As Double
51. For i = 0 To UBound(pInsertPnts)
52. pDPnts(i * 3) = pInsertPnts(i)(0)
53. pDPnts(i * 3 + 1) = pInsertPnts(i)(1)
54. pDPnts(i * 3 + 2) = pInsertPnts(i)(2)
55. Next i
56. ThisDrawing.ModelSpace.Add3DPoly(pDPnts).Rotate3D pLine.StartPoint, pLine.EndPoint, Atn(1) * 2
57. Next pLine
58. ErrHandle:
59. For i = 0 To ss.Count - 1
60. p1(2) = pPnts(i)(2)
61. ss(i).Move p2, p1
62. Next i
63. ThisDrawing.SelectionSets("*TlsTest*").Delete
64. ThisDrawing.SelectionSets("*TlsTestLine*").Delete
65. End Sub
66. Private Sub SortPoint(ByRef Values As Variant, ByRef Points As Variant, ByVal Count As Integer)
67. '按值将点数组排序
68. Dim pTemp As Double, pnt As VariantFor i = Count To 1 Step -1For j = 0 To i - 1If Values(j) > Values(j + 1) Then
69. pTemp = Values(j + 1)
70. Values(j + 1) = Values(j)
71. Values(j) = pTemp
72. pnt = Points(j + 1)
73. Points(j + 1) = Points(j)
74. Points(j) = pnt
75. End IfNext jNext iEnd Sub

Sub t9() On Error GoTo ErrHandle Dim ss As AcadSelectionSet Dim ssLine As AcadSelectionSet Dim ft(0) As Integer, fd(0) Dim p1(2) As Double, p2(2) As Double Dim pPnts() Dim pLine As AcadLine, dot Dim i, j Dim pInsertPnt Dim pInsertPnts() Dim pNum As Integer Dim pnt(2) As DoubleDim pStart, PEnd Dim pCount As Integer Dim pDistances() As Double Set ss = ThisDrawing.SelectionSets.Add("*TlsTest*") ft(0) = 0: fd(0) = "Spline" ss.Select acSelectionSetAll, , , ft, fd ReDim pPnts(ss.Count - 1) For i = 0 To ss.Count - 1 pPnts(i) = ss(i).ControlPoints p1(2) = pPnts(i)(2) ss(i).Move p1, p2 Next i Set ssLine = ThisDrawing.SelectionSets.Add("*TlsTestLine*") ft(0) = 0: fd(0) = "Line"ssLine.Select acSelectionSetAll, , , ft, fd For Each pLine In ssLine pNum = 0 For i = 0 To ss.Count - 1 pInsertPnt = pLine.IntersectWith(ss(i), acExtendNone) n = (UBound(pInsertPnt) + 1) / 3 For j = 0 To n - 1 pnt(0) = pInsertPnt(j * 3) pnt(1) = pInsertPnt(j * 3 + 1) pnt(2) = pPnts(i)(2) ReDim Preserve pInsertPnts(pNum) pInsertPnts(pNum) = pnt pNum = pNum + 1 Next j Next ipStart = pLine.StartPoint PEnd = pLine.EndPoint pCount = UBound(pInsertPnts)If Abs(Tan(pLine.Angle)) < 1 Then pNum = 0 Else pNum = 1ReDim pDistances(pCount) As Double For i = 0 To pCount pDistances(i) = Abs(pInsertPnts(i)(pNum) - pStart(pNum)) Next i SortPoint pDistances, pInsertPnts, pCount Dim pDPnts() As Double pNum = UBound(pInsertPnts) * 3 + 2 ReDim pDPnts(pNum) As Double For i = 0 To UBound(pInsertPnts) pDPnts(i * 3) = pInsertPnts(i)(0) pDPnts(i * 3 + 1) = pInsertPnts(i)(1) pDPnts(i * 3 + 2) = pInsertPnts(i)(2) Next i ThisDrawing.ModelSpace.Add3DPoly(pDPnts).Rotate3D pLine.StartPoint, pLine.EndPoint, Atn(1) * 2 Next pLine ErrHandle: For i = 0 To ss.Count - 1 p1(2) = pPnts(i)(2) ss(i).Move p2, p1 Next i ThisDrawing.SelectionSets("*TlsTest*").Delete ThisDrawing.SelectionSets("*TlsTestLine*").Delete End Sub Private Sub SortPoint(ByRef Values As Variant, ByRef Points As Variant, ByVal Count As Integer) '按值将点数组排序 Dim pTemp As Double, pnt As VariantFor i = Count To 1 Step -1For j = 0 To i - 1If Values(j) > Values(j + 1) Then pTemp = Values(j + 1) Values(j + 1) = Values(j) Values(j) = pTemp pnt = Points(j + 1) Points(j + 1) = Points(j) Points(j) = pnt End IfNext jNext iEnd Sub

daydayup

谢谢斑竹的帮助！！我是个初学者，看这个程序有点困难。斑竹同志能不能再给小弟讲解一下


我的等高线是Spline吧

雪山飞狐_lzh

先将曲线Move到Z＝0，与直线求交点，再还原曲线

daydayup

谢谢斑竹热心答疑啦!

daydayup

版主同志好！！我实在是刚开始接触vba，有好多函数、方法都不懂。请问有什么书对这些有个详细的介绍呢？？我现在在看MJTD推出的AutoCAD VBA 虽然收获不少，但还是有好多东西不会啊！我该怎么学习VBA呢？？


我上面的图的等高线是扫描后矢量化的，我现在就连在平面上多条曲线和指定直线求交点都还不会，麻烦版主及各位前辈教教我！！

雪山飞狐_lzh

先看看这 [WEB]http://www.vba.cn/object/acad2004/[/WEB]

daydayup

太谢谢版主了

daydayup

小弟我把版主给我参考的剖面测试代码改了改，想在一个新的图形窗口画出所得的剖面。可是我创建了新的窗口后原来代码中的 ErrHandle:
For i = 0 To ss.Count - 1
p1(2) = pPnts(i)(2)
ss(i).Move p2, p1
Next i
ThisDrawing.SelectionSets("*TlsTest*").Delete
ThisDrawing.SelectionSets("*TlsTestLine*").Delete 就出现了错误（对象变量和with块变量未设置）。是不是因为新的窗口没有定义 i 和选择集，要切换到原来的图形窗口。请问我该怎么做呢？ 再问一句，创建所得的剖面有什么好的是现代码吗？ 剖面是以相邻两点的XOY投影距离为横坐标，高程差为纵坐标。我觉得我实现的好麻烦啊，头都晕了