沙漠骆驼工具箱源码-9 桩号标注

woxing1987

工具条：桩号标注，界面和代码如下：
1 界面：




2代码如下：

    Option Explicit '要求变量声明
    Dim zigao As Single   '字体高度
    Dim xscale As Double   '设置比例
    Dim jianju As Integer  '设置桩号间距
    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 ComboBox2_Change()
    xscale = ComboBox2.Text
End Sub

Private Sub CommandButton1_Click() '框选多段线进行桩号标注
    Me.Hide
    zigao = ComboBox1.Text
    jianju = ComboBox3.Text
    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")

    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

    Dim filtertype As Variant, filterdata As Variant
    Call createssetfilter(filtertype, filterdata, 0, "lwpolyline")
    ThisDrawing.Utility.prompt ("请框选平面线，进行桩号标注:")
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf 'vbcrlf '表示换行显示
        Me.show
        sset1.Clear
        sset1.Delete
        Exit Sub
    End If

    Set layerobj = ThisDrawing.Layers.Add("桩号标注")
    layerobj.color = acGreen
    ThisDrawing.SetVariable "cecolor", "256"
    ThisDrawing.ActiveLayer = layerobj
    newtextstyle2    '调用新建字体样式程序
    ThisDrawing.SetVariable "textstyle", "wh_lkx"

    '下面插入桩号 从0 开始
    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 renyizhuanghao As Double
    For Each pingmianxian In sset1
        'pingmianxian.Elevation = 0 '将平面线标高归零，以备不时之需
        pmxchangdu = pingmianxian.length * xscale / 1000 '单位为米
        renyizhuanghao = 0
        geshi = "0+000"
        Do While renyizhuanghao < pmxchangdu    '循环添加桩号
            charudian1 = dianweizhi(renyizhuanghao, xscale, pingmianxian)
            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
            renyizhuanghao = renyizhuanghao + jianju
        Loop
        '加入最后一个桩号 归到插入拐点桩号里面了
        geshi = "0+000.000"
        renyizhuanghao = pmxchangdu
        charudian1 = dianweizhi(renyizhuanghao, xscale, pingmianxian)
        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

        '是否插入拐点桩号
        If CheckBox1.value Then
            geshi = "0+000.000"
            Dim ii As Integer
            Dim guaidian As Variant
            For ii = 1 To UBound(pingmianxian.Coordinates) \ 2 - 1
                guaidian = pingmianxian.Coordinate(ii)
                charudian1(0) = guaidian(0)
                charudian1(1) = guaidian(1)
                charudian1(2) = 0
                renyizhuanghao = (diandaoqidianjuli(guaidian, 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
            Next
        End If
    Next
    sset1.Clear
    sset1.Delete
    Me.show
    '恢复系统变量
    With ThisDrawing
        .ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
        .SetVariable "textstyle", currenttextstyle
        .SetVariable "OSMODE", currentosmode
        .SetVariable "cecolor", currentcolor
    End With
End Sub

Private Sub CommandButton3_Click()
    Me.Hide
End Sub


Private Sub CommandButton4_Click() '单选多段线进行桩号标注
    Me.Hide
    zigao = ComboBox1.Text
    jianju = ComboBox3.Text
    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")

    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
    pmxchangdu = pingmianxian.length * xscale / 1000 '单位为米

    ThisDrawing.SetVariable "OSMODE", 1
    basepoint = ThisDrawing.Utility.GetPoint(, vbCrLf & "请拾取桩号起始点(多段线端点):")

    If Err.Number <> 0 Then
        ThisDrawing.Utility.prompt "-----多段线端点拾取失败------" & vbCrLf
        Me.show
        Err.Clear
        ThisDrawing.SetVariable "OSMODE", currentosmode
        Exit Sub
    End If
    pingmianxian.Highlight False
    '下面判断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)

    If Int(basepoint(0)) <> Int(qidian(0)) And Int(basepoint(1)) <> Int(qidian(1)) Then '拾取点不是多段线的起点，反向
        Call fanzhuanduoduanxian(pingmianxian)
    End If

    Set layerobj = ThisDrawing.Layers.Add("桩号标注")
    layerobj.color = acGreen
    ThisDrawing.SetVariable "cecolor", "256"
    ThisDrawing.ActiveLayer = layerobj
    newtextstyle2    '调用新建字体样式程序
    ThisDrawing.SetVariable "textstyle", "wh_lkx"


    '下面插入桩号 从0 开始
    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 renyizhuanghao As Double
    geshi = "0+000"
    Do While renyizhuanghao < pmxchangdu    '循环添加桩号
        charudian1 = dianweizhi(renyizhuanghao, xscale, pingmianxian)
        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
        renyizhuanghao = renyizhuanghao + jianju
    Loop
    '加入最后一个桩号 归到插入拐点桩号里面了
    geshi = "0+000.000"
    renyizhuanghao = pmxchangdu
    charudian1 = dianweizhi(renyizhuanghao, xscale, pingmianxian)
    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

    '是否插入拐点桩号
    If CheckBox1.value Then
        geshi = "0+000.000"
        Dim ii As Integer
        Dim guaidian As Variant
        For ii = 1 To UBound(pingmianxian.Coordinates) \ 2 - 1
            guaidian = pingmianxian.Coordinate(ii)
            charudian1(0) = guaidian(0)
            charudian1(1) = guaidian(1)
            charudian1(2) = 0
            renyizhuanghao = (diandaoqidianjuli(guaidian, 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
        Next
    End If
    Me.show
    '恢复系统变量
    With ThisDrawing
        .ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
        .SetVariable "textstyle", currenttextstyle
        .SetVariable "OSMODE", currentosmode
        .SetVariable "cecolor", currentcolor
    End With
End Sub


Private Sub Label11_Click()
    Me.Hide
    On Error Resume Next
    ThisDrawing.SetVariable "CMDECHO", 0
    Dim pt1 As Variant
    Dim pt2 As Variant
    pt1 = ThisDrawing.Utility.GetPoint(, "请拾取第一点:")
    pt2 = ThisDrawing.Utility.GetPoint(pt1, "请拾取第二点:")
    Dim tushangjuli As Double
    Dim shijijuli As Double
    tushangjuli = distancep1p2(pt1, pt2)
    shijijuli = ThisDrawing.Utility.GetReal("请输入该段的实际距离(单位为m):")
    If Err Then
        ThisDrawing.Utility.prompt "-----执行错误，请重新操作------" & vbCrLf
        Me.show
        Exit Sub
    End If
    xscale = shijijuli * 1000 / tushangjuli
    Label3.Caption = "1:" & Format(xscale, "0.00")
    Me.show
End Sub

Private Sub OptionButton4_Click()
    If OptionButton4.value Then
        ComboBox2.Enabled = True
        Label11.Enabled = False
        Label3.Enabled = False
    End If
End Sub

Private Sub OptionButton5_Click()
    If OptionButton5.value Then
        ComboBox2.Enabled = False
        Label11.Enabled = True
        Label3.Enabled = True
    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 = 1 To 10
        ComboBox1.AddItem i * 10
    Next
    For i = 2 To 10
        ComboBox1.AddItem i * 100
    Next
    For i = 2 To 5
        ComboBox1.AddItem i * 1000
    Next

    ComboBox2.AddItem 1 '设置当前图形水平比例
    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
    '设置桩号间距
    ComboBox3.AddItem 5
    ComboBox3.AddItem 10
    ComboBox3.AddItem 20
    ComboBox3.AddItem 25
    For i = 0 To 3
        ComboBox3.AddItem 10 * ComboBox3.List(i)
    Next
    For i = 0 To 3
        ComboBox3.AddItem 100 * ComboBox3.List(i)
    Next
    xscale = 1000
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

f4800

沙漠骆驼工具箱源码-9 桩号标注  感谢分享。。虽然看不懂 但是大佬的分享精神值得学习