沙漠骆驼工具箱源码-11查询及插入高程

woxing1987

工具条：查询及插入高程，界面和代码如下：
1 界面：


2 代码如下


    Dim zigao As Single   '字体高度
    Dim yscale As Double   '设置垂直比例
    Dim basepoint As Variant
    Dim jianqieban As New DataObject
    Dim jizhungc As Double    '定义基准高程


Private Sub ComboBox1_Change()
    zigao = ComboBox1.Text
End Sub


Private Sub ComboBox2_Change()
    yscale = ComboBox2.Text
    Label11.Caption = yscale
End Sub


Private Sub CommandButton1_Click()  '拾取或修改高程基准 jizhungc
    Me.Hide
    On Error Resume Next
    zigao = ComboBox1.Text
    yscale = ComboBox2.Text
    dy = Left(ComboBox4.Text, 2)
    ThisDrawing.SetVariable "textstyle", "wh_lkx"


    basepoint = ThisDrawing.Utility.GetPoint(, "拾取高程基准点:")
    ThisDrawing.Utility.prompt "输入高程基准值(0)：" & vbCrLf
    jizhungc = ThisDrawing.Utility.GetReal()


    Label10.Caption = jizhungc
    Label11.Caption = yscale


    Me.height = 227
    Me.show
End Sub


Private Sub CommandButton2_Click() '显示任意一点高程
    Me.Hide
    Dim charudian1 As Variant
    Dim xianshidian As AcadCircle
    On Error GoTo e1
    Dim linshidian(0 To 2) As Double
    linshidian(0) = 0: linshidian(1) = 0: linshidian(2) = 0
   
    Set xianshidian = ThisDrawing.ModelSpace.AddCircle(linshidian, zigao) '先随便画一个圆，一个小小的技巧
r1:
    charudian1 = ThisDrawing.Utility.GetPoint(, "拾取任意一点:")
    xianshidian.Delete
    Set xianshidian = ThisDrawing.ModelSpace.AddCircle(charudian1, zigao)
    xianshidian.color = acRed
    xianshidian.Highlight True
    Dim renyibiaogao As Double
    renyibiaogao = jizhungc + (charudian1(1) - basepoint(1)) * yscale / 1000
    'ThisDrawing.Utility.Prompt "-----改点高程为：" & Format(renyibiaogao, "0.000") & " 米-----" & vbCrLf
   
    ThisDrawing.ModelSpace.AddText Format(renyibiaogao, "0.000"), charudian1, zigao
   
    '复制到剪切板上
    jianqieban.SetText Format(renyibiaogao, "0.000")
    jianqieban.PutInClipboard
    ThisDrawing.Utility.prompt "-----改点高程已经复制到剪切板上-----" & vbCrLf
e1:
    If Err.Number <> 0 Then
        Err.Clear
        Me.show
        xianshidian.Delete
        Exit Sub
    Else
        GoTo r1
    End If
End Sub


Private Sub CommandButton3_Click()
    Me.Hide
End Sub


Private Sub CommandButton4_Click() '查询任一点高程
    Me.Hide
    Dim charudian1 As Variant
    Dim xianshidian As AcadCircle
    On Error GoTo e1
    Dim linshidian(0 To 2) As Double
    linshidian(0) = 0: linshidian(1) = 0: linshidian(2) = 0
   
    Set xianshidian = ThisDrawing.ModelSpace.AddCircle(linshidian, zigao)
r1:
    charudian1 = ThisDrawing.Utility.GetPoint(, "拾取任意一点:")
    xianshidian.Delete
    Set xianshidian = ThisDrawing.ModelSpace.AddCircle(charudian1, zigao)
    xianshidian.color = acRed
    xianshidian.Highlight True
    Dim renyibiaogao As Double
    renyibiaogao = jizhungc + (charudian1(1) - basepoint(1)) * yscale / 1000
    ThisDrawing.Utility.prompt "-----该点高程为：" & Format(renyibiaogao, "0.000") & " 米-----" & vbCrLf
   
    '复制到剪切板上
    jianqieban.SetText Format(renyibiaogao, "0.000")
    jianqieban.PutInClipboard
    ThisDrawing.Utility.prompt "-----改点高程已经复制到剪切板上-----" & vbCrLf
   
   
    'ThisDrawing.ModelSpace.AddText Format(renyibiaogao, "0.000"), charudian1, zigao
e1:
    If Err.Number <> 0 Then
        Err.Clear
        Me.show
        xianshidian.Delete
        Exit Sub
    Else
        GoTo r1
    End If
End Sub


Private Sub CommandButton5_Click() '插入给定的高程
    Me.Hide
    Dim gaochengzhi As Double
    Dim charudian1 As Variant
    Dim xianshidian As AcadCircle
    On Error GoTo e1
    Dim linshidian(0 To 2) As Double
    linshidian(0) = 0: linshidian(1) = 0: linshidian(2) = 0
   
    Set xianshidian = ThisDrawing.ModelSpace.AddCircle(linshidian, 1) '先随便画一个圆，一个小小的技巧
r1:
    gaochengzhi = ThisDrawing.Utility.GetReal("请输入高程:")
    charudian1 = ThisDrawing.Utility.GetPoint(, "请拾取高程插入点(坚方向):")
   
    charudian1(1) = basepoint(1) + (gaochengzhi - jizhungc) * 1000 / yscale
    charudian1(2) = 0
'    MsgBox basepoint(1)
'    MsgBox gaochengzhi
'    MsgBox jizhungc
'    MsgBox yscale
    'MsgBox (gaochengzhi - jizhungc) * 1000 / yscale
   ' MsgBox charudian1(1)
    'ThisDrawing.Utility.Prompt "-----该点高程为：" & Format(renyibiaogao, "0.000") & " 米-----" & vbCrLf
   
    ThisDrawing.ModelSpace.AddText Format(gaochengzhi, "0.000"), charudian1, zigao
    ThisDrawing.ModelSpace.AddCircle charudian1, zigao / 3
    xianshidian.Delete
    Set xianshidian = ThisDrawing.ModelSpace.AddCircle(charudian1, zigao)
    xianshidian.color = acRed
    xianshidian.Highlight True
   
    '跳到插入点并最大化显示
    Dim zuoxiadian As Variant
    Dim youshangdian As Variant
    xianshidian.GetBoundingBox zuoxiadian, youshangdian
    zuoxiadian(0) = zuoxiadian(0) - 20
    youshangdian(0) = youshangdian(0) + 20
    ThisDrawing.Application.ZoomWindow zuoxiadian, youshangdian
   
e1:
    If Err.Number <> 0 Then
        Err.Clear
        Me.show
        xianshidian.Delete
        Exit Sub
    Else
        GoTo r1
    End If
End Sub


Private Sub UserForm_Initialize()
    Dim i As Integer
    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---1000
        ComboBox1.AddItem i
    Next
   
    ComboBox2.AddItem 0.1
    ComboBox2.AddItem 0.2
    ComboBox2.AddItem 0.5
    ComboBox2.AddItem 1 '设置垂直比例10-50000
    ComboBox2.AddItem 2
    ComboBox2.AddItem 5
    ComboBox2.AddItem 10
    ComboBox2.AddItem 20
    ComboBox2.AddItem 25
    ComboBox2.AddItem 50
    For i = 3 To 6
        ComboBox2.AddItem 10 * ComboBox2.List(i)
    Next
    For i = 3 To 6
        ComboBox2.AddItem 100 * ComboBox2.List(i)
    Next
    For i = 3 To 6
        ComboBox2.AddItem 1000 * ComboBox2.List(i)
    Next
    Me.height = 96
    newtextstyle2 '调用新建字体样式程序
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