沙漠骆驼工具箱源码-18获取高程范围（等高线）

woxing1987

工具条：获取高程范围（等高线）
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

lxl217114

大佬的分享精神值得学习+1

czb203

大佬的分享精神值得学习+1

烟盒迷唇

不错不错啊