线状高程点的提取

测不准

思路：先将所要提取的高程点用复合线连接起来（对象捕捉只选圆心）先用论坛中的多线段顶点坐标程序提取高程点的坐标XY和高程点的个数。然后按照高程点的块属性，根据多线段顶点坐标进行筛选，获得所要提取的高程点的高程值。
在模块中添加以下代码：
Type gcd '定义高程点
p_name As String '点名
x As Double 'X
y As Double 'Y
z As Double 'H
End Type
Function tqddzb(n As Integer) As gcd() '提取多线段顶点坐标
Dim ss_dim As AcadSelectionSet, ent As AcadLWPolyline '提取高程点坐标XY，为下一步搜索高程点做准备
Dim i As Integer, j As Integer
Dim g() As gcd
n = 0
Debug.Assert (ss_dim Is Nothing)
On Error Resume Next
If Not IsNull(ThisDrawing.SelectionSets.Item("ssLine1")) Then
Set ss_dim = ThisDrawing.SelectionSets.Item("ssLine1")
    ss_dim.Delete
End If
Set ss_dim = ThisDrawing.SelectionSets.Add("ssLine1")
If ss_dim Is Nothing Then
MsgBox "创建选择集失败！"
End
End If
'Set ss_dim = ThisDrawing.SelectionSets.Add("ssLine1")

ss_dim.SelectOnScreen
'首先确定顶点个数，以便定义动态数组
For Each ent In ss_dim
For j = 0 To UBound(ent.Coordinates) \ 2
n = n + 1
Next
Next
ReDim g(0 To n) As gcd '定义动态数组

n = 0 '重新归零
For Each ent In ss_dim
For j = 0 To UBound(ent.Coordinates) \ 2
g(j).x = ent.Coordinates(j * 2)
g(j).y = ent.Coordinates(j * 2 + 1)
n = n + 1
Next
Next
tqddzb = g()
ss_dim.Clear
ss_dim.Delete
End Function

在 thisdrawing中添加以下代码：
Sub qtgcd()
Dim pnum As Integer '定义多线段顶点个数
Dim s_gcd() As gcd
Dim objblock As AcadBlockReference
Dim sset As AcadSelectionSet
Dim intcnt As Integer
Dim mtype(2) As Integer, mdata(2) As Variant
Dim varattributes As Variant

tqddzb pnum '获取顶点个数
MsgBox pnum & "pnum"
ReDim s_gcd(0 To pnum) As gcd '定义顶点坐标动态数组
s_gcd() = tqddzb(pnum)
Dim i As Integer
'For i = 0 To pnum - 1
'MsgBox s_gcd(i).x
'Next
Debug.Assert (sset Is Nothing)
On Error Resume Next
If Not IsNull(ThisDrawing.SelectionSets.Item("GCD")) Then
Set sset = ThisDrawing.SelectionSets.Item("GCD")
    sset.Delete
End If
Set sset = ThisDrawing.SelectionSets.Add("GCD")
If sset Is Nothing Then
MsgBox "创建选择集失败！"
End
End If
mtype(0) = 0: mdata(0) = "insert"
mtype(1) = 8: mdata(1) = "GCD"
mtype(2) = 2: mdata(2) = "GC200"
sset.Select acSelectionSetAll, , , mtype, mdata
i = 0
If sset.Count > 0 Then
For Each objblock In sset
For i = 0 To pnum
If Abs(s_gcd(i).x - objblock.InsertionPoint(0)) < 0.01 And Abs(s_gcd(i).y - objblock.InsertionPoint(1)) < 0.01 Then
s_gcd(i).z = objblock.InsertionPoint(2)
End If
Next
Next
End If
MsgBox Round(s_gcd(2).z, 2) '验证程序
sset.Delete
End Sub



如有更好的思路，请大家不吝赐教！

wkq004

连目的都没看懂呀!!

skg123

估计楼主想绘制纵断面图；

happy336

谢谢分享，支持