沙漠骆驼工具箱源码-13查询及桩号(平面)

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 pingmianxian As AcadLWPolyline  '定义平面线
    Dim pmxchangdu As Double '定义平面线长度
    Dim geshi As String


Private Sub CommandButton1_Click()  '拾取或修改桩号基准 jizhunzh
    Me.Hide
    On Error Resume Next
    zigao = ComboBox1.Text
    xscale = ComboBox2.Text
    Dim base As Variant
    ThisDrawing.Utility.GetEntity pingmianxian, base, vbCrLf & "请拾取平面线，必须为多段线:"
    If Err.Number <> 0 Then
        ThisDrawing.Utility.prompt "-----平面线拾取失败------" & vbCrLf
        Me.show
        Err.Clear
        Exit Sub
    End If
    pingmianxian.Elevation = 0 '将平面线标高归零，以便后面使用
    ThisDrawing.Utility.prompt "-----平面线拾取成功------" & vbCrLf
    pingmianxian.Highlight True
    Dim currentosmode As Integer
    currentosmode = ThisDrawing.GetVariable("OSMODE")
    ThisDrawing.SetVariable "OSMODE", 1
   
    basepoint = ThisDrawing.Utility.GetPoint(, vbCrLf & "拾取桩号基准点(多段线端点):")
    pingmianxian.Highlight False
    If Err.Number <> 0 Then
        ThisDrawing.Utility.prompt "-----多段线端点拾取失败------" & vbCrLf
        Me.show
        Err.Clear
        Exit Sub
    End If
   
    '下面判断basepoint 是否为多段线的起点坐标，如果不是，则反向，调用多段线反向程序
    Dim qidian(0 To 1) As Double
    Dim zhongdian(0 To 1) As Double
    qidian(0) = pingmianxian.Coordinates(0)
    qidian(1) = pingmianxian.Coordinates(1)
    'zhongdian(0) = pingmianxian.Coordinates(UBound(pingmianxian.Coordinates) - 1)
    'zhongdian(1) = pingmianxian.Coordinates(UBound(pingmianxian.Coordinates))
    'MsgBox qidian(0)
    'MsgBox qidian(1)
   
    If Int(basepoint(0)) <> Int(qidian(0)) And Int(basepoint(1)) <> Int(qidian(1)) Then '拾取点不是多段线的起点，反向
        Call fanzhuanduoduanxian(pingmianxian)
    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)
    pmxchangdu = pingmianxian.length * xscale / 1000 '单位为米
    Label11.Caption = Format(pmxchangdu, "0.000")
   
    newtextstyle2 '调用新建字体样式程序
    ThisDrawing.SetVariable "textstyle", "wh_lkx"
    ThisDrawing.SetVariable "OSMODE", currentosmode
    Me.height = 227
    Me.show
End Sub


Private Sub CommandButton2_Click() '显示任意一点桩号
    Me.Hide
    Dim zhuanghaozhi As AcadText
    Dim zhuanghaoxian As AcadLine
    Dim modian(0 To 2) As Double
    Dim text1 As Variant, text2 As Variant
    Dim charudian1 As Variant
    Dim xianshidian As AcadCircle
    Dim layerobj As AcadLayer
    Dim currentosmode As Integer
    Dim currentlayername As String
    Dim currentcolor As String
    Dim currenttextstyle As String
    On Error Resume Next
    currentlayername = ThisDrawing.ActiveLayer.name
    currentcolor = ThisDrawing.GetVariable("cecolor")
    currentosmode = ThisDrawing.GetVariable("OSMODE")
    currenttextstyle = ThisDrawing.GetVariable("textstyle")
    Set layerobj = ThisDrawing.Layers.Add("桩号标注")
    layerobj.color = acGreen
    ThisDrawing.SetVariable "cecolor", "256"
    ThisDrawing.ActiveLayer = layerobj
    ThisDrawing.SetVariable "OSMODE", 513
    newtextstyle2    '调用新建字体样式程序
    ThisDrawing.SetVariable "textstyle", "wh_lkx"
    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:
    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 + (diandaoqidianjuli(charudian1, pingmianxian)) * xscale / 1000
   
    geshi = "0+000.000"
    If renyizhuanghao = Int(renyizhuanghao) Then geshi = "0+000"


    Set zhuanghaozhi = ThisDrawing.ModelSpace.AddText(Format(renyizhuanghao, geshi), charudian1, zigao)
    zhuanghaozhi.GetBoundingBox text1, text2
    modian(0) = charudian1(0) + distancep1p2(text1, text2)
    modian(1) = charudian1(1)
    zhuanghaozhi.Rotation = fangxiang(charudian1, pingmianxian)
    Set zhuanghaoxian = ThisDrawing.ModelSpace.AddLine(charudian1, modian)
    zhuanghaoxian.Rotate charudian1, zhuanghaozhi.Rotation
    '复制到剪切板上
    jianqieban.SetText Format(renyizhuanghao, geshi)
    jianqieban.PutInClipboard
    ThisDrawing.Utility.prompt "-----该点桩号已经复制到剪切板上-----" & vbCrLf
e1:
    If Err.Number <> 0 Then
        Err.Clear
        Me.show
        xianshidian.Delete
        '重置系统变量
        With ThisDrawing
            .ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
            .SetVariable "OSMODE", currentosmode
            .SetVariable "cecolor", currentcolor '恢复绘图颜色
            .SetVariable "textstyle", currenttextstyle
        End With
        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
    Dim currentosmode As Integer
    currentosmode = ThisDrawing.GetVariable("OSMODE")
    ThisDrawing.SetVariable "OSMODE", 513
    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 + (diandaoqidianjuli(charudian1, pingmianxian)) * 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
        ThisDrawing.SetVariable "OSMODE", currentosmode
        xianshidian.Delete
        Exit Sub
    Else
        GoTo r1
    End If
End Sub


Private Sub CommandButton5_Click() '插入给定的桩号
    Me.Hide
    Dim zhuanghaozhi As AcadText
    Dim renyizhuanghao As Double
    Dim zhuanghaoxian As AcadLine
    Dim modian(0 To 2) As Double
    Dim text1 As Variant, text2 As Variant
    Dim charudian1 As Variant
    Dim xianshidian As AcadCircle
    Dim layerobj As AcadLayer
    Dim currentlayername As String
    Dim currenttextstyle As String
    On Error Resume Next
    currentlayername = ThisDrawing.ActiveLayer.name
    currenttextstyle = ThisDrawing.GetVariable("textstyle")
    Set layerobj = ThisDrawing.Layers.Add("桩号标注")
    layerobj.color = acGreen
    ThisDrawing.SetVariable "cecolor", "256"
    ThisDrawing.ActiveLayer = layerobj
    newtextstyle2    '调用新建字体样式程序
    ThisDrawing.SetVariable "textstyle", "wh_lkx"
    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:
    renyizhuanghao = ThisDrawing.Utility.GetReal("请输入桩号值(m):")
    If renyizhuanghao > pmxchangdu Then
        MsgBox "桩号超出范围！", vbCritical
        Me.show
        xianshidian.Delete
        '重置系统变量
        With ThisDrawing
            .ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
            .SetVariable "textstyle", currenttextstyle
        End With
        Exit Sub
    End If
    charudian1 = dianweizhi(renyizhuanghao, xscale, pingmianxian)
   
    geshi = "0+000.000"
    If renyizhuanghao = Int(renyizhuanghao) Then geshi = "0+000"
    Set zhuanghaozhi = ThisDrawing.ModelSpace.AddText(Format(renyizhuanghao, geshi), charudian1, zigao)
    zhuanghaozhi.GetBoundingBox text1, text2
    modian(0) = charudian1(0) + distancep1p2(text1, text2)
    modian(1) = charudian1(1)
    zhuanghaozhi.Rotation = fangxiang(charudian1, pingmianxian)
    Set zhuanghaoxian = ThisDrawing.ModelSpace.AddLine(charudian1, modian)
    zhuanghaoxian.Rotate charudian1, zhuanghaozhi.Rotation
   
    xianshidian.Delete
    Set xianshidian = ThisDrawing.ModelSpace.AddCircle(charudian1, zigao)
    xianshidian.color = acRed
    xianshidian.Highlight True
e1:
    If Err.Number <> 0 Then
        Err.Clear
        Me.show
        xianshidian.Delete
        '重置系统变量
        With ThisDrawing
            .ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
            .SetVariable "textstyle", currenttextstyle
        End With
        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
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
'求两点之间的距离,参数是(x1,y1),(x2,y2)


Private Function distancep1p2(ByVal p1 As Variant, ByVal p2 As Variant) As Double
    distancep1p2 = ((p1(0) - p2(0)) ^ 2 + (p1(1) - p2(1)) ^ 2) ^ 0.5
End Function