沙漠骆驼工具箱源码-12查询及桩号(纵断面)

woxing1987

工具条：查询及桩号，界面和代码如下：
1 界面：




2 代码如下：



    Option Explicit '要求变量声明
    Dim zigao As Single   '字体高度
    Dim xscale As Double   '设置垂直比例
    Dim basepoint As Variant
    Dim jianqieban As New DataObject
    Dim jizhunzh As Double    '定义基准桩号
    Dim geshi As String


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


Private Sub CommandButton1_Click()  '拾取或修改桩号基准 jizhunzh
    Me.Hide
    On Error Resume Next
    zigao = ComboBox1.Text
    xscale = ComboBox2.Text


    ThisDrawing.SetVariable "textstyle", "wh_lkx"


    basepoint = ThisDrawing.Utility.GetPoint(, "请拾取桩号基准点:")
    If Err.Number <> 0 Then
        ThisDrawing.Utility.prompt "-----桩号基准点拾取失败------" & vbCrLf
        Me.show
        Err.Clear
        Exit Sub
    End If
   
    ThisDrawing.Utility.prompt "请输入桩号基准值(默认为0)：" & vbCrLf
    jizhunzh = ThisDrawing.Utility.GetReal()
   
    geshi = "0+000.000"
    If jizhunzh = Int(jizhunzh) Then geshi = "0+000"


    Label10.Caption = Format(jizhunzh, geshi)
    Label11.Caption = xscale


    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 renyizhuanghao As Double
    renyizhuanghao = jizhunzh + (charudian1(0) - basepoint(0)) * xscale / 1000
    'ThisDrawing.Utility.Prompt "-----该点桩号为：" & Format(renyibiaogao, "0.000") & " 米-----" & vbCrLf
   
    geshi = "0+000.000"
    If renyizhuanghao = Int(renyizhuanghao) Then geshi = "0+000"


    ThisDrawing.ModelSpace.AddText Format(renyizhuanghao, geshi), charudian1, zigao
   
    '复制到剪切板上
    jianqieban.SetText Format(renyizhuanghao, geshi)
    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 renyizhuanghao As Double
    renyizhuanghao = jizhunzh + (charudian1(0) - basepoint(0)) * xscale / 1000
   
    geshi = "0+000.000"
    If renyizhuanghao = Int(renyizhuanghao) Then geshi = "0+000"
   
    ThisDrawing.Utility.prompt "-----该点桩号为：" & Format(renyizhuanghao, geshi) & " 米-----" & vbCrLf
   
    '复制到剪切板上
    jianqieban.SetText Format(renyizhuanghao, geshi)
    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 zhuanghaozhi 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:
    zhuanghaozhi = ThisDrawing.Utility.GetReal("请输入桩号:")
    charudian1 = ThisDrawing.Utility.GetPoint(, "请拾取桩号插入点:")
   
    charudian1(0) = basepoint(0) + (zhuanghaozhi - jizhunzh) * 1000 / xscale
    charudian1(2) = 0
   
    'ThisDrawing.Utility.Prompt "-----该点桩号为：" & Format(renyibiaogao, "0.000") & " 米-----" & vbCrLf
    geshi = "0+000.000"
    If zhuanghaozhi = Int(zhuanghaozhi) Then geshi = "0+000"
    ThisDrawing.ModelSpace.AddText Format(zhuanghaozhi, geshi), 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---500
        ComboBox1.AddItem i
    Next
    ComboBox2.AddItem 1 '设置水平比例1-500000
    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
    For i = 3 To 6
        ComboBox2.AddItem 10000 * 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

czb203

谢谢群主分享