沙漠骆驼工具箱源码-5长度统计

woxing1987

工具条：长度统计，界面和代码如下：
1 界面：



2 代码如下：



    Dim sumlength As Double  'sumarea
    Dim xiaoshuweishu As Integer
    Dim zigao As Double
    'Dim bilichi As Double
    Dim xbilichi As Double
    Dim ybilichi As Double
   
    Dim bilichi As Double
    Dim bilichi1 As Double
    Dim bilichi2 As Double
    Dim danwei As String
   
    '框选对象进行分类统计 里面用的
    Private Type layerclass   '根据图层分类
        name As String    '图层名称
        sumchangdu As Double ' 长度
        yuanobj As AcadObject '定义原对象，以获取对象的属性
    End Type
  
   
    Dim layerlength() As Double ' 存储每个图层中图元 的长度和
    Dim alllength As Double  '用来存储总的长度
    Dim lengthtongji() As layerclass
            
    Dim currenttextstyle As String
    Dim currentlayername As String
    Dim lengthlayer As AcadLayer    'lengthlayer


Private Sub ComboBox5_Change()
    bilichi1 = ComboBox2.Text
End Sub




Private Sub CommandButton1_Click() '框选对象直接求总长度
    If OptionButton4.value Then bilichi = ComboBox2.Text
    If OptionButton5.value Then bilichi = bilichi2
    If OptionButton5.value And Label3.Caption = "" Then
        MsgBox "请获取当前图形的比例尺！", vbCritical, "获取比例尺"
        Exit Sub
    End If
    Me.Hide
    On Error Resume Next
    currenttextstyle = ThisDrawing.GetVariable("textstyle")
    currentlayername = ThisDrawing.ActiveLayer.name
    Set lengthlayer = ThisDrawing.Layers.Add("长度统计")
    lengthlayer.color = acGreen
    ThisDrawing.SetVariable "cecolor", "256"
    ThisDrawing.ActiveLayer = lengthlayer


    Dim sset1 As AcadSelectionSet
    Dim filtertype(4) As Integer '定义选择过滤器类型的dsf组码
    Dim filterdata(4) As Variant '定义过滤器的值
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "line"
    filtertype(2) = 0
    filterdata(2) = "lwpolyline"
    filtertype(3) = 0
    filterdata(3) = "POLYLINE"
    filtertype(4) = -4
    filterdata(4) = "or>"
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请框选要统计长度的对象:")
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        Me.show
        Exit Sub
    End If
    zigao = ComboBox1.Text
'    xbilichi = ComboBox2.Text
'    ybilichi = ComboBox4.Text
    xiaoshuweishu = ComboBox3.Text


    sumlength = 0
    Dim duixiang As AcadObject
    For Each duixiang In sset1
        sumlength = sumlength + duixiang.length
    Next
    If OptionButton1.value Then
        danwei = " m"
        sumlength = sumlength * bilichi / 10 ^ 3 'bilichi
    Else
        danwei = " km"
        sumlength = sumlength * bilichi / 10 ^ 6
    End If
    Dim basepoint As Variant
    Dim geshi As String
   
    ThisDrawing.SetVariable "textstyle", "wh_lkx"
    geshi = "0." & Right("00000", xiaoshuweishu)
    basepoint = ThisDrawing.Utility.GetPoint(, "请拾取插入点:")
    Dim mianjitext As AcadText
    Set mianjitext = ThisDrawing.ModelSpace.AddText("当前图形比例尺 1:" & bilichi, basepoint, zigao)
    basepoint(1) = basepoint(1) - zigao * 2
    Set mianjitext = ThisDrawing.ModelSpace.AddText( _
                "对象个数:" & sset1.count & "。  " & _
                "总长度为:" & Format(sumlength, geshi) & danwei, basepoint, zigao)
   
    '恢复文字样式
    ThisDrawing.SetVariable "textstyle", currenttextstyle
    '恢复图层
    ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
    Me.show
End Sub


Private Sub CommandButton2_Click()
    Me.Hide
End Sub


Private Sub CommandButton4_Click() '框选对象进行分类统计
    If OptionButton4.value Then bilichi = ComboBox2.Text
    If OptionButton5.value Then bilichi = bilichi2
    If OptionButton5.value And Label3.Caption = "" Then
        MsgBox "请获取当前图形的比例尺！", vbCritical, "获取比例尺"
        Exit Sub
    End If
    Me.Hide
    zigao = ComboBox1.Text
'    xbilichi = ComboBox2.Text
'    ybilichi = ComboBox4.Text
    xiaoshuweishu = ComboBox3.Text
    On Error Resume Next


    currenttextstyle = ThisDrawing.GetVariable("textstyle")
    currentlayername = ThisDrawing.ActiveLayer.name
    Set lengthlayer = ThisDrawing.Layers.Add("长度统计")
    lengthlayer.color = acGreen
    ThisDrawing.SetVariable "cecolor", "256"
    ThisDrawing.ActiveLayer = lengthlayer


    Dim sset1 As AcadSelectionSet
    Dim filtertype(4) As Integer '定义选择过滤器类型的dsf组码
    Dim filterdata(4) As Variant '定义过滤器的值
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "line"
    filtertype(2) = 0
    filterdata(2) = "lwpolyline"
    filtertype(3) = 0
    filterdata(3) = "POLYLINE"
    filtertype(4) = -4
    filterdata(4) = "or>"
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请框选要统计长度的对象:")
    sset1.SelectOnScreen filtertype, filterdata
   
    If sset1.count = 0 Then
        Me.show
        Exit Sub
    End If


    Dim i As Integer
    Dim j As Integer
    ReDim layerlength(ThisDrawing.Layers.count - 1)
   
    Dim changduobj As AcadObject
    ReDim huoquobj(sset1.count - 1) As Double
    Dim count1 As Double
    For i = 0 To ThisDrawing.Layers.count - 1
        For Each changduobj In sset1
            If ThisDrawing.Layers.Item(i).name = changduobj.Layer Then
                layerlength(i) = layerlength(i) + changduobj.length
                'Set huoquobj(count1) = changduobj
            End If
            'count1 = count1 + 1
        Next
        If layerlength(i) <> 0 Then  '记录长度不为零的图层个数
            j = j + 1
        End If
    Next
'    If j = 0 Then
'        Me.Show
'        Exit Sub
'    End If
    ReDim lengthtongji(0 To j - 1)
    Dim jj As Double
    For i = 0 To ThisDrawing.Layers.count - 1
        If layerlength(i) <> 0 Then
            lengthtongji(jj).name = ThisDrawing.Layers.Item(i).name
            lengthtongji(jj).sumchangdu = layerlength(i)
            'Set lengthtongji(jj).yuanobj = sset
            jj = jj + 1
        End If
    Next
    alllength = 0


    For i = 0 To UBound(lengthtongji)
        If OptionButton1.value Then
            lengthtongji(i).sumchangdu = lengthtongji(i).sumchangdu * bilichi / 10 ^ 3
        Else
            lengthtongji(i).sumchangdu = lengthtongji(i).sumchangdu * bilichi / 10 ^ 6
        End If
        alllength = alllength + lengthtongji(i).sumchangdu    '求总长度
    Next
   
    If OptionButton1.value Then
        danwei = " m"
    Else
        danwei = " km"
    End If
    Dim basepoint As Variant
    basepoint = ThisDrawing.Utility.GetPoint(, "拾取统计表格插入点:")
   
    '画统计表格
    ThisDrawing.SetVariable "textstyle", "wh_lkx"
   
    Dim biaotoukuan As Double '设定 表格长度
    Dim biaotougao As Double '设定 表格高度
    If zigao < 4 Then
        biaotoukuan = 20
        biaotougao = 8
    Else
        biaotoukuan = zigao * 8
        biaotougao = zigao * 2.5
    End If
    Dim hengxian As AcadLWPolyline
    Dim p1p2(0 To 3) As Double
    p1p2(0) = basepoint(0): p1p2(1) = basepoint(1)
    p1p2(2) = basepoint(0) + 5 * biaotoukuan: p1p2(3) = p1p2(1)
    ThisDrawing.ModelSpace.AddLightWeightPolyline p1p2
    p1p2(0) = basepoint(0): p1p2(1) = basepoint(1) - biaotougao
    p1p2(2) = basepoint(0) + 5 * biaotoukuan: p1p2(3) = p1p2(1)
    ThisDrawing.ModelSpace.AddLightWeightPolyline p1p2
   
    For i = 0 To UBound(lengthtongji)
        p1p2(0) = basepoint(0): p1p2(1) = p1p2(1) - biaotougao
        p1p2(2) = basepoint(0) + 5 * biaotoukuan: p1p2(3) = p1p2(1)
        ThisDrawing.ModelSpace.AddLightWeightPolyline p1p2
    Next
    For i = 0 To 5
        p1p2(0) = basepoint(0) + biaotoukuan * i
        p1p2(1) = basepoint(1)
        p1p2(2) = p1p2(0)
        ThisDrawing.ModelSpace.AddLightWeightPolyline p1p2
    Next
   
    Dim p2p4(0 To 7) As Double
    p2p4(0) = basepoint(0): p2p4(1) = p1p2(3)
    p2p4(2) = basepoint(0): p2p4(3) = p1p2(3) - biaotougao
    p2p4(4) = basepoint(0) + 5 * biaotoukuan: p2p4(5) = p2p4(3)
    p2p4(6) = p2p4(4): p2p4(7) = p2p4(1)
    ThisDrawing.ModelSpace.AddLightWeightPolyline p2p4
   
    Dim mingcheng As AcadText
    Dim charudian(0 To 2) As Double
    charudian(0) = basepoint(0) + biaotoukuan * 0.5
    charudian(1) = basepoint(1) - biaotougao * 0.5
    Set mingcheng = ThisDrawing.ModelSpace.AddText("序 号", charudian, zigao)
    With mingcheng
        .Alignment = acAlignmentMiddleCenter
        .TextAlignmentPoint = charudian
    End With
    charudian(0) = basepoint(0) + biaotoukuan * 1.5
    charudian(1) = basepoint(1) - biaotougao * 0.5
    Set mingcheng = ThisDrawing.ModelSpace.AddText("图层名称", charudian, zigao)
    mingcheng.Alignment = acAlignmentMiddleCenter
    mingcheng.TextAlignmentPoint = charudian
   
    charudian(0) = basepoint(0) + biaotoukuan * 2.5
    charudian(1) = basepoint(1) - biaotougao * 0.5
    Set mingcheng = ThisDrawing.ModelSpace.AddText("图 例", charudian, zigao)
    mingcheng.Alignment = acAlignmentMiddleCenter
    mingcheng.TextAlignmentPoint = charudian
   
    charudian(0) = basepoint(0) + biaotoukuan * 3.5
    charudian(1) = basepoint(1) - biaotougao * 0.5
    Set mingcheng = ThisDrawing.ModelSpace.AddText("长 度", charudian, zigao)
    mingcheng.Alignment = acAlignmentMiddleCenter
    mingcheng.TextAlignmentPoint = charudian
   
    charudian(0) = basepoint(0) + biaotoukuan * 4.5
    charudian(1) = basepoint(1) - biaotougao * 0.5
    Set mingcheng = ThisDrawing.ModelSpace.AddText("单 位", charudian, zigao)
    mingcheng.Alignment = acAlignmentMiddleCenter
    mingcheng.TextAlignmentPoint = charudian
   
    '插入序号和单位
    For i = 1 To UBound(lengthtongji) + 1
        charudian(0) = basepoint(0) + biaotoukuan * 0.5
        charudian(1) = basepoint(1) - (i + 0.5) * biaotougao
        Set mingcheng = ThisDrawing.ModelSpace.AddText(i, charudian, zigao)
        mingcheng.Alignment = acAlignmentMiddleCenter
        mingcheng.TextAlignmentPoint = charudian
    Next
    For i = 1 To UBound(lengthtongji) + 1
        charudian(0) = basepoint(0) + biaotoukuan * 4.5
        charudian(1) = basepoint(1) - (i + 0.5) * biaotougao
        Set mingcheng = ThisDrawing.ModelSpace.AddText(danwei, charudian, zigao)
        mingcheng.Alignment = acAlignmentMiddleCenter
        mingcheng.TextAlignmentPoint = charudian
    Next
   
    Dim geshi As String
    geshi = "0." & Right("00000", xiaoshuweishu)
    charudian(0) = basepoint(0) + biaotoukuan * 2.5
    charudian(1) = basepoint(1) - (i + 0.5) * biaotougao
   
    Set mingcheng = ThisDrawing.ModelSpace.AddText( _
                        "对象个数:" & sset1.count & "。  " & _
                        "总长度=" & Format(alllength, geshi) & danwei, charudian, zigao)
    mingcheng.Alignment = acAlignmentMiddleCenter
    mingcheng.TextAlignmentPoint = charudian
   
    '插入图层名称、图例 和长度数据
    For i = 1 To UBound(lengthtongji) + 1
        charudian(0) = basepoint(0) + biaotoukuan * 1.5
        charudian(1) = basepoint(1) - (i + 0.5) * biaotougao
        Set mingcheng = ThisDrawing.ModelSpace.AddText(lengthtongji(i - 1).name, charudian, zigao)
        mingcheng.Alignment = acAlignmentMiddleCenter
        mingcheng.TextAlignmentPoint = charudian
    Next
    Dim tulipline As AcadLWPolyline '设置图例线型
    Dim yuanline As AcadObject
    Dim tulilist(0 To 3) As Double
    For i = 1 To UBound(lengthtongji) + 1
        charudian(0) = basepoint(0) + biaotoukuan * 2.5
        charudian(1) = basepoint(1) - (i + 0.5) * biaotougao
        tulilist(0) = charudian(0) - biaotoukuan * 0.4
        tulilist(1) = charudian(1)
        tulilist(2) = charudian(0) + biaotoukuan * 0.4
        tulilist(3) = charudian(1)
        Set tulipline = ThisDrawing.ModelSpace.AddLightWeightPolyline(tulilist)
        tulipline.Layer = lengthtongji(i - 1).name
        'tulipline.Linetype = "bylayer"
        'tulipline.color = acByLayer
        'tulipline.Lineweight = acLnWtByLayer
        'tulipline.LinetypeScale = 0.2
'        With dmxzdm
'            .Linetype = zdmxian.Linetype
'            .Layer = zdmxian.Layer
'            .LinetypeScale = zdmxian.LinetypeScale
'            .Lineweight = zdmxian.Lineweight
'            .ConstantWidth = zdmxian.ConstantWidth
'            .LinetypeGeneration = zdmxian.LinetypeGeneration
'            .color = zdmxian.color
'        End With
    Next
    For i = 1 To UBound(lengthtongji) + 1
        charudian(0) = basepoint(0) + biaotoukuan * 3.5
        charudian(1) = basepoint(1) - (i + 0.5) * biaotougao
        Set mingcheng = ThisDrawing.ModelSpace.AddText(Format(lengthtongji(i - 1).sumchangdu, geshi), charudian, zigao)
        mingcheng.Alignment = acAlignmentMiddleCenter
        mingcheng.TextAlignmentPoint = charudian
    Next
   


   
    charudian(0) = basepoint(0)
    charudian(1) = basepoint(1) + biaotougao * 0.5


    Set mingcheng = ThisDrawing.ModelSpace.AddText("当前图形比例尺 1:" & bilichi, charudian, zigao)
   
    '恢复文字样式
    ThisDrawing.SetVariable "textstyle", currenttextstyle
    '恢复图层
    ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
   
    sset1.Clear
    sset1.Delete
    Me.show
End Sub


Private Sub Label2_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
    bilichi2 = shijijuli * 1000 / tushangjuli
    Label3.Caption = "1:" & Format(bilichi2, "0.00")
    Me.show
End Sub


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




Private Sub OptionButton5_Click()
    If OptionButton5.value Then
        ComboBox2.Enabled = False
        Label2.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 = 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 '设置当前图形水平比例
    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 1 '设置小数位数
    ComboBox3.AddItem 2
    ComboBox3.AddItem 3
    ComboBox3.AddItem 4
    ComboBox3.AddItem 5
    newtextstyle2    '调用新建字体样式程序
    bilichi1 = ComboBox2.Text
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