沙漠骆驼工具箱源码-17设置标高（等高线）

woxing1987

工具条：设置标高（等高线）
1 界面


2 代码如下：





Dim top1 As Single
Dim top2 As Single
Dim top3 As Single
Dim top4 As Single
Dim top5 As Single
Dim top6 As Single
Dim dizengyinzi As Integer  '定义递增因子，说明是递增还是递减


Private Sub CommandButton1_Click()
    On Error Resume Next
    Me.Hide
    quxiao '调用取消命令
    Dim zigao As Double
    Dim denggaoju As Double
    zigao = ComboBox1.Text
    denggaoju = ComboBox2.Text
    Dim gaocheng As Double
    Dim pickbox1 As Integer
    Dim currentcolor As String
    Dim currenttextstyle As String
    Dim currentlayername As String
    Dim currentosmode As Integer
    Dim layerobj As AcadLayer
   
    pickbox1 = ThisDrawing.GetVariable("pickbox")
    currentcolor = ThisDrawing.GetVariable("cecolor")
    currenttextstyle = ThisDrawing.GetVariable("textstyle")
    currentlayername = ThisDrawing.ActiveLayer.name
    currentosmode = ThisDrawing.GetVariable("OSMODE")
    Dim filtertype(3) As Integer '定义选择过滤器类型的dsf组码
    Dim filterdata(3) 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>"
    Dim sset1 As AcadSelectionSet
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    newtextstyle2    '调用新建字体样式程序
    If OptionButton1.value Then '如果是单选
        Dim plineobj As AcadObject
        Dim base As Variant
redo1:
        ThisDrawing.SetVariable "pickbox", 5
        ThisDrawing.SetVariable "cmdecho", 0
        ThisDrawing.Utility.GetEntity plineobj, base, "请点选等高线:" & vbCrLf
        sset1.SelectAtPoint base, filtertype, filterdata
        If sset1.count = 0 Then
            ThisDrawing.Utility.prompt "-----等高线获取错误，请重新操作------" & vbCrLf
            chongzhi pickbox1, currentcolor, currenttextstyle, currentlayername, currentosmode
            Me.show
            Exit Sub
        Else
            ThisDrawing.Utility.prompt "当前等高线高程为:" & plineobj.Elevation & vbCrLf
            gaocheng = ThisDrawing.Utility.GetReal(vbCr & "请输入高程:")
            If gaocheng = 0 Then
                sset1.Clear
                GoTo redo1 '如果为输入高程为0，则重新选择等高线
            Else
                plineobj.Elevation = gaocheng
                sset1.Clear
                gaocheng = 0
            End If
            If CheckBox1.value Then
                Set layerobj = ThisDrawing.Layers.Add("高程文字")
                ThisDrawing.ActiveLayer = layerobj
                currenttextstyle = ThisDrawing.GetVariable("textstyle")
                layerobj.color = acRed
                ThisDrawing.SetVariable "cecolor", "256"
                ThisDrawing.SetVariable "textstyle", "wh_lkx"
                addgaocheng plineobj.Elevation, base, zigao
                chongzhi pickbox1, currentcolor, currenttextstyle, currentlayername, currentosmode
            End If
            GoTo redo1
        End If
        Me.show
    Else '如果是选择多条等高线  栏选等高线
        Dim pt1 As Variant
        Dim pt2 As Variant
'redo2:
        ThisDrawing.SetVariable "osmode", 0
        pt1 = ThisDrawing.Utility.GetPoint(, "拾取第一点:")
        pt2 = ThisDrawing.Utility.GetPoint(pt1, "拾取第二点:")
        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
        Dim line1 As AcadLine
        Set line1 = ThisDrawing.ModelSpace.AddLine(pt1, pt2)
        line1.Highlight True
        Dim boundary1 As Variant
        Dim boundary2 As Variant
        line1.GetBoundingBox boundary1, boundary2
        ThisDrawing.Application.ZoomWindow boundary1, boundary2
        sset1.SelectByPolygon acSelectionSetFence, linelist, filtertype, filterdata '栏选对象
        ThisDrawing.Application.ZoomPrevious '返回上一个屏幕
        If sset1.count = 0 Then
            ThisDrawing.Utility.prompt "-----等高线获取错误，请重新操作------" & vbCrLf
            chongzhi pickbox1, currentcolor, currenttextstyle, currentlayername, currentosmode
            line1.Delete
            Me.show
            Exit Sub
        Else
            gaocheng = ThisDrawing.Utility.GetReal("请输入起始高程:")
            dizengyinzi = 1 '默认表示递增
            
            dizengyinzi = ThisDrawing.Utility.GetInteger(vbCr & "递增(1)或递减(-1)默认是递增：")
'            If gaocheng = 0 Then
'                line1.Delete
'                sset1.Clear
'                'GoTo redo2 '如果输入高程为0，则重新选择等高线
'            End If
            Dim i As Integer
            If CheckBox1.value Then '是否显示标高文字
                Set layerobj = ThisDrawing.Layers.Add("高程文字")
                currenttextstyle = ThisDrawing.GetVariable("textstyle")
                layerobj.color = acRed
                ThisDrawing.ActiveLayer = layerobj
                ThisDrawing.SetVariable "textstyle", "wh_lkx"
                Dim jiaodian As Variant
                Dim intpoint(0 To 2) As Double
                For i = 0 To sset1.count - 1
                    sset1.Item(i).Elevation = 0
                    jiaodian = sset1.Item(i).IntersectWith(line1, acExtendNone)
                    intpoint(0) = jiaodian(0)
                    intpoint(1) = jiaodian(1)
                    addgaocheng gaocheng + i * denggaoju * dizengyinzi, intpoint, zigao
                Next
                chongzhi pickbox1, currentcolor, currenttextstyle, currentlayername, currentosmode
            End If
            For i = 0 To sset1.count - 1
                sset1.Item(i).Elevation = gaocheng + i * denggaoju * dizengyinzi
            Next
            line1.Delete
            sset1.Clear
            sset1.Delete
            'GoTo redo2
        End If
        Me.show
    End If
End Sub


Private Sub CommandButton2_Click()
    Me.Hide
End Sub


Private Sub CommandButton3_Click()
    On Error Resume Next
    Me.Hide
    quxiao '调用取消命令
    Dim zigao As Double
    Dim denggaoju As Double
    zigao = ComboBox1.Text
    denggaoju = ComboBox2.Text
    Dim gaocheng As Double
    Dim pickbox1 As Integer
    Dim currentcolor As String
    Dim currenttextstyle As String
    Dim currentlayername As String
    Dim layerobj As AcadLayer
    Dim currentosmode As Integer
   
    pickbox1 = ThisDrawing.GetVariable("pickbox")
    currentcolor = ThisDrawing.GetVariable("cecolor")
    currenttextstyle = ThisDrawing.GetVariable("textstyle")
    currentlayername = ThisDrawing.ActiveLayer.name
    currentosmode = ThisDrawing.GetVariable("OSMODE")
    Dim filtertype(3) As Integer '定义选择过滤器类型的dsf组码
    Dim filterdata(3) 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>"
    Dim sset1 As AcadSelectionSet
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    newtextstyle2    '调用新建字体样式程序
    If OptionButton1.value Then '如果是单选
        Dim plineobj As AcadObject
        Dim base As Variant
redo1:
        ThisDrawing.SetVariable "pickbox", 5
        ThisDrawing.SetVariable "cmdecho", 0
        ThisDrawing.Utility.GetEntity plineobj, base, "请点选等高线:" & vbCrLf
        sset1.Clear
        sset1.SelectAtPoint base, filtertype, filterdata
        If sset1.count = 0 Then
            ThisDrawing.Utility.prompt "-----等高线获取错误，请重新操作------" & vbCrLf
            chongzhi pickbox1, currentcolor, currenttextstyle, currentlayername, currentosmode
            Me.show
            Exit Sub
        Else
            If CheckBox1.value Then
                ThisDrawing.Utility.prompt "当前等高线高程为:" & plineobj.Elevation & vbCrLf
                Set layerobj = ThisDrawing.Layers.Add("高程文字")
                ThisDrawing.ActiveLayer = layerobj
                currenttextstyle = ThisDrawing.GetVariable("textstyle")
                layerobj.color = acRed
                ThisDrawing.SetVariable "cecolor", "256"
                ThisDrawing.SetVariable "textstyle", "wh_lkx"
                addgaocheng plineobj.Elevation, base, zigao
                chongzhi pickbox1, currentcolor, currenttextstyle, currentlayername, currentosmode
                GoTo redo1
            Else
                ThisDrawing.Utility.prompt "当前等高线高程为:" & plineobj.Elevation & vbCrLf
                GoTo redo1
            End If
        End If
        Me.show
    Else '如果是选择多条等高线
        Dim pt1 As Variant
        Dim pt2 As Variant
        ThisDrawing.SetVariable "osmode", 0
        pt1 = ThisDrawing.Utility.GetPoint(, "拾取第一点:")
        pt2 = ThisDrawing.Utility.GetPoint(pt1, "拾取第二点:")
        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
        Dim line1 As AcadLine
        Set line1 = ThisDrawing.ModelSpace.AddLine(pt1, pt2)
        line1.Highlight True
        Dim boundary1 As Variant
        Dim boundary2 As Variant
        line1.GetBoundingBox boundary1, boundary2
        ThisDrawing.Application.ZoomWindow boundary1, boundary2
        sset1.SelectByPolygon acSelectionSetFence, linelist, filtertype, filterdata '栏选对象
        ThisDrawing.Application.ZoomPrevious '返回上一个屏幕
        If sset1.count = 0 Then
            ThisDrawing.Utility.prompt "-----等高线获取错误，请重新操作------" & vbCrLf
            chongzhi pickbox1, currentcolor, currenttextstyle, currentlayername, currentosmode
            line1.Delete
            Me.show
            Exit Sub
        End If
        Set layerobj = ThisDrawing.Layers.Add("高程文字")
        currenttextstyle = ThisDrawing.GetVariable("textstyle")
        layerobj.color = acRed
        ThisDrawing.ActiveLayer = layerobj
        ThisDrawing.SetVariable "textstyle", "wh_lkx"
        ThisDrawing.SetVariable "osmode", 0
        Dim jiaodian As Variant
        Dim intpoint(0 To 2) As Double
        For i = 0 To sset1.count - 1
            gaocheng = sset1.Item(i).Elevation
            sset1.Item(i).Elevation = 0
            jiaodian = sset1.Item(i).IntersectWith(line1, acExtendNone)
            intpoint(0) = jiaodian(0)
            intpoint(1) = jiaodian(1)
            addgaocheng gaocheng, intpoint, zigao
            sset1.Item(i).Elevation = gaocheng
        Next
        chongzhi pickbox1, currentcolor, currenttextstyle, currentlayername, currentosmode
        line1.Delete
        sset1.Clear
        sset1.Delete
        Me.show
    End If
End Sub


Private Sub OptionButton1_Click()
    Label2.Visible = False
    ComboBox2.Visible = False
    Label1.top = top1
    ComboBox1.top = top2
    CheckBox1.top = top3
    CommandButton1.top = top4
    CommandButton2.top = top5
    CommandButton3.top = top6
    Me.height = 166
End Sub


Private Sub OptionButton2_Click()
    Label2.Visible = True
    ComboBox2.Visible = True
    Label1.top = top1 + 18
    ComboBox1.top = top2 + 18
    CheckBox1.top = top3 + 18
    CommandButton1.top = top4 + 18
    CommandButton2.top = top5 + 18
    CommandButton3.top = top6 + 18
    Me.height = 184
End Sub


Private Sub UserForm_Initialize()
    Dim i As Single
    For i = 1 To 19  '设置字体高度
        ComboBox1.AddItem Format(i / 2 + 0.5, "0.0")
    Next
    For i = 15 To 95 Step 5  '15---95
        ComboBox1.AddItem i
    Next
    For i = 100 To 1000 Step 50 '100---500
        ComboBox1.AddItem i
    Next
   
   
    '设置等高距
    ComboBox2.AddItem Format(0.5, "0.0")
    For i = 1 To 10 Step 0.5
        ComboBox2.AddItem Format(i, "0.0")
    Next
    ComboBox2.AddItem Format(10, "0.0")
    ComboBox2.AddItem Format(20, "0.0")
    ComboBox2.AddItem Format(40, "0.0")
    ComboBox2.AddItem Format(50, "0.0")
    ComboBox2.AddItem Format(100, "0.0")
    top1 = Label1.top
    top2 = ComboBox1.top
    top3 = CheckBox1.top
    top4 = CommandButton1.top
    top5 = CommandButton2.top
    top6 = CommandButton3.top
End Sub


''创建新的字体样式
'Private Sub newtextstyle()   '创建新的字体样式
'    Dim typeFace As String
'    Dim SavetypeFace As String
'    Dim Bold As Boolean
'    Dim Italic As Boolean
'    Dim charSet As Long
'    Dim PitchandFamily As Long
'    Dim lkxtextstyle As AcadTextStyle
'    Dim currenttextstyle As AcadTextStyle
'    Set currenttextstyle = ThisDrawing.ActiveTextStyle
'    '获取当前字体样式的参数
'    currenttextstyle.GetFont typeFace, Bold, Italic, charSet, PitchandFamily
'    Set lkxtextstyle = ThisDrawing.TextStyles.Add("wh_lkx")
'    With lkxtextstyle
'        .SetFont "宋体", False, False, charSet, PitchandFamily
'        .width = 0.8   '设置宽度比例
'    End With
'End Sub


Private Sub addgaocheng(gaocheng As Double, pt As Variant, zigao As Double)
    Dim textobj As AcadText
    Set textobj = ThisDrawing.ModelSpace.AddText(Format(gaocheng, "0.0"), pt, zigao)
    With textobj
        .Alignment = acAlignmentMiddleCenter
        .TextAlignmentPoint = pt
    End With
End Sub

Private Sub chongzhi(pickbox1 As Integer, currentcolor As String, currenttextstyle As String, currentlayername As String, currentosmode As Integer)
    '重置系统变量
    With ThisDrawing
        .SetVariable "pickbox", pickbox1
        .SetVariable "cmdecho", 0
        .SetVariable "cecolor", currentcolor '恢复绘图颜色
        .SetVariable "textstyle", currenttextstyle
        .SetVariable "osmode", currentosmode
    End With
    '恢复图层
    ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
End Sub