沙漠骆驼工具箱源码-18获取高程范围（等高线）
工具条：获取高程范围（等高线）1 界面
2 代码如下：
Dim dgxlayername As String
Private Sub CommandButton1_Click() '拉线获取高程
Me.Hide
ThisDrawing.SetVariable "CMDECHO", 0
Dim pt1 As Variant
Dim pt2 As Variant
ThisDrawing.ObjectSnapMode = False '关闭对象捕捉
pt1 = ThisDrawing.Utility.GetPoint(, "拾取第一点:")
pt2 = ThisDrawing.Utility.GetPoint(pt1, "拾取第二点:")
If Err Then
ThisDrawing.Utility.prompt "-----拾取失败，请重新操作------" & vbCrLf
Err.Clear
Me.show
Exit Sub
End If
Dim sset As AcadSelectionSet '创建等高线选择集
Dim filtertype(4) As Integer '定义选择过滤器类型的dsf组码
Dim filterdata(4) As Variant '定义选择过滤器的值
filtertype(0) = -4
filterdata(0) = "<or"
filtertype(1) = 0
filterdata(1) = "lwpolyline"
filtertype(2) = 0
filterdata(2) = "polyline"
filtertype(3) = -4
filterdata(3) = "or>"
filtertype(4) = 8
filterdata(4) = dgxlayername
On Error Resume Next
Set sset = ThisDrawing.SelectionSets.Add("ss1")
If Err.Number <> 0 Then
Err.Clear
Set sset = ThisDrawing.SelectionSets.Item("ss1")
sset.Clear
End If
Dim linelist(0 To 5) As Double '用于栏选对象
linelist(0) = pt1(0): linelist(1) = pt1(1): linelist(2) = 0
linelist(3) = pt2(0): linelist(4) = pt2(1): linelist(5) = 0
ThisDrawing.Application.ZoomWindow pt1, pt2
sset.SelectByPolygon acSelectionSetFence, linelist, filtertype, filterdata'栏选对象
ThisDrawing.Application.ZoomPrevious '返回上一个屏幕
If sset.count = 0 Then
'dgxlayername = "" '如果没切到等高线，将dgxlayername 设为空值
sset.Clear
sset.Delete '删除选择集
Me.show
Exit Sub '并且退出
End If
Dim i As Double
Dim maxgaocheng1 As Double
Dim mingaocheng1 As Double
maxgaocheng1 = sset.Item(0).Elevation
mingaocheng1 = maxgaocheng1
For i = 1 To sset.count - 1
If sset.Item(i).Elevation > maxgaocheng1 Then
maxgaocheng1 = sset.Item(i).Elevation
ElseIf sset.Item(i).Elevation < mingaocheng1 Then
mingaocheng1 = sset.Item(i).Elevation
End If
Next
Label13.Caption = maxgaocheng1
Label15.Caption = mingaocheng1
Me.show
End Sub
Private Sub CommandButton2_Click()
Me.Hide
End Sub
Private Sub Label2_Click() '点击获取等高线图层
Me.Hide
Dim plineobj As AcadEntity
Dim base As Variant
On Error Resume Next
ThisDrawing.Utility.GetEntity plineobj, base, "请选取等高线，以获取等高线所在的图层名称:" & vbCrLf
If Err.Number <> 0 Or (plineobj.ObjectName <> "AcDb2dPolyline" And plineobj.ObjectName <> "AcDbPolyline") Then
ThisDrawing.Utility.prompt "-----等高线选取失败------" & vbCrLf
Me.show
Exit Sub
End If
ThisDrawing.Utility.prompt "-----获取等高线图层成功-----" & vbCrLf
Label1.Caption = plineobj.Layer
dgxlayername = Label1.Caption
Dim filtertype(4) As Integer '定义选择过滤器类型的dsf组码
Dim filterdata(4) As Variant '定义选择过滤器的值
filtertype(0) = -4
filterdata(0) = "<or"
filtertype(1) = 0
filterdata(1) = "lwpolyline"
filtertype(2) = 0
filterdata(2) = "polyline"
filtertype(3) = -4
filterdata(3) = "or>"
filtertype(4) = 8
filterdata(4) = dgxlayername
Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
If Err.Number <> 0 Then
Err.Clear
Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
sset1.Clear
End If
sset1.Select acSelectionSetAll, , , filtertype, filterdata
Dim i As Double
Dim maxgaocheng As Double
Dim mingaocheng As Double
maxgaocheng = sset1.Item(0).Elevation
mingaocheng = maxgaocheng
For i = 1 To sset1.count - 1
'If (sset1.Item(i).ObjectName = "AcDb2dPolyline" Or sset1.Item(i).ObjectName = "AcDbPolyline") _
'And sset1.Item(i).Layer = dgxlayername Then
'Set dgxobjs(j) = sset1.Item(i)
'End If
If sset1.Item(i).Elevation > maxgaocheng Then
maxgaocheng = sset1.Item(i).Elevation
ElseIf sset1.Item(i).Elevation < mingaocheng Then
mingaocheng = sset1.Item(i).Elevation
End If
Next
Label3.Caption = maxgaocheng
Label4.Caption = mingaocheng
Me.show
Me.height = 212
End Sub
Private Sub UserForm_Initialize()
Me.height = 116
End Sub
大佬的分享精神值得学习+1 大佬的分享精神值得学习+1 不错不错啊
页:
[1]