沙漠骆驼工具箱源码-4面积统计

woxing1987

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


2代码如下：




    Option Explicit '强制要求变量声明
    Dim sumarea As Double
    Dim xiaoshuweishu As Integer
    Dim zigao As Double
    'Dim bilichi As Double
    Dim xbilichi As Double
    Dim ybilichi As Double
    Dim danwei As String
   
    '框选对象进行分类统计 里面用的
    Private Type layerclass   '根据图层分类
        name As String    '图层名称
        summianji As Double '面积
    End Type

    Dim layermianji() As Double ' 存储每个图层中图元 的面积和
    Dim allmianji As Double  '用来存储总的面积
    Dim mianjitongji() As layerclass
            
    Dim currenttextstyle As String
    Dim currentlayername As String
    Dim arealayer As AcadLayer
   
Private Sub CommandButton1_Click() '框选对象直接求总面积
    Me.Hide
    On Error Resume Next
    'quxiao '调用取消命令
    currenttextstyle = ThisDrawing.GetVariable("textstyle")
    currentlayername = ThisDrawing.ActiveLayer.name
    Set arealayer = ThisDrawing.Layers.Add("面积统计")
    arealayer.color = acGreen
    ThisDrawing.SetVariable "cecolor", "256"
    With arealayer
        .LayerOn = True
        .Lock = False
        .Freeze = False
    End With
    ThisDrawing.ActiveLayer = arealayer
    Dim sset1 As AcadSelectionSet
    Dim filtertype(9) As Integer '定义选择过滤器类型的dsf组码
    Dim filterdata(9) As Variant '定义过滤器的值
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "CIRCLE"
    filtertype(2) = 0
    filterdata(2) = "ARC"
    filtertype(3) = 0
    filterdata(3) = "SPLINE"
    filtertype(4) = 0
    filterdata(4) = "lwpolyline"
    filtertype(5) = 0
    filterdata(5) = "POLYLINE"
    filtertype(6) = 0
    filterdata(6) = "REGION"  '面域对象
    filtertype(7) = 0
    filterdata(7) = "HATCH"  '填充对象  填充的面积属性在 2006 版本中支持 Hatch 对象
    filtertype(8) = 0
    filterdata(8) = "ellipse" '椭圆对象
    filtertype(9) = -4
    filterdata(9) = "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


    sumarea = 0
    Dim duixiang As AcadObject
    For Each duixiang In sset1
        sumarea = sumarea + duixiang.Area
    Next
    If OptionButton1.value Then
        danwei = "㎡"
        sumarea = sumarea * xbilichi * ybilichi / 10 ^ 6
    ElseIf OptionButton4.value Then
        danwei = "亩"
        sumarea = sumarea * xbilichi * ybilichi / 10 ^ 10 * 15
    Else
        danwei = "K㎡"
        sumarea = sumarea * xbilichi * ybilichi / 10 ^ 12
    End If
    Dim basepoint As Variant
    Dim geshi As String
    newtextstyle1    '调用新建字体样式程序
    ThisDrawing.SetVariable "textstyle", "wh_lkx1"
    geshi = "0." & Right("00000", xiaoshuweishu)
    basepoint = ThisDrawing.Utility.GetPoint(, "请拾取插入点:")
    Dim mianjitext As AcadText
    Set mianjitext = ThisDrawing.ModelSpace.AddText("当前图形比例尺  x方向：1:" & xbilichi _
                                                               & "  y方向：1:" & ybilichi, basepoint, zigao)
    basepoint(1) = basepoint(1) - zigao * 2
    Set mianjitext = ThisDrawing.ModelSpace.AddText( _
                "对象个数:" & sset1.count & "。  " & _
                "总面积为:" & Format(sumarea, 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 CommandButton3_Click() '点击封闭区域求面积
    Me.Hide
     '设置ucs为世界坐标系
    ThisDrawing.SendCommand "ucs" & vbCr & "w" & vbCr
    Dim currentosmode As Integer
    currentosmode = ThisDrawing.GetVariable("osmode")
    On Error Resume Next
    ThisDrawing.SetVariable "cmdecho", 0
    ThisDrawing.SetVariable "HPBOUND", 0 '边界创建为面域 面域是从闭合的形或环创建的二维区域。
                                        '闭合多段线、直线和曲线都是有效的选择对象。
                                        '曲线包括圆弧、圆、椭圆弧、椭圆和样条曲线。
    ThisDrawing.SetVariable "OSMODE", 0
    'ThisDrawing.ObjectSnapMode = False '关闭对象捕捉
    currenttextstyle = ThisDrawing.GetVariable("textstyle")
    currentlayername = ThisDrawing.ActiveLayer.name
    Set arealayer = ThisDrawing.Layers.Add("面积统计")
    With arealayer
        .LayerOn = True
        .Lock = False
        .Freeze = False
    End With
    ThisDrawing.ActiveLayer = arealayer
    newtextstyle1    '调用新建字体样式程序 宋体
    ThisDrawing.SetVariable "textstyle", "wh_lkx1"
   
    'ThisDrawing.Regen acActiveViewport '重生成一下图形
   
    Dim basepoint As Variant
    'Dim plineobj As AcadObject
    Dim mianyu As AcadRegion  '定义面域对象
    On Error GoTo ee1
r1:
    basepoint = ThisDrawing.Utility.GetPoint(, "请拾取封闭区域内的某一点:")
    Dim countnow As Integer  '此处设定一个变量，用于记录当前图形个数，
                             '如果创建不成功，则图形个数不变，退出程序
    countnow = ThisDrawing.ModelSpace.count
   
    ThisDrawing.SendCommand "-boundary" & vbCr & "a" & vbCr & "i" & vbCr & "n" & vbCr & vbCr & vbCr & _
                                "(command (list " & basepoint(0) & " " & basepoint(1) & ")"""")" & vbCr
    'ThisDrawing.SendCommand "(command ""-boundary """ & "(list " & basepoint(0) & " " & basepoint(1) & ")"""") "
   
    If ThisDrawing.ModelSpace.count = countnow Then
        Me.show
        ThisDrawing.SendCommand "ucs" & vbCr & "p" & vbCr
        Exit Sub
    End If
    Set mianyu = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.count - 1)
   
    Dim objarea As Double
    objarea = mianyu.Area
    zigao = ComboBox1.Text
    xbilichi = ComboBox2.Text
    ybilichi = ComboBox4.Text
    xiaoshuweishu = ComboBox3.Text


    If OptionButton1.value Then
        danwei = "㎡"
        objarea = objarea * xbilichi * ybilichi / 10 ^ 6
    ElseIf OptionButton4.value Then
        danwei = "亩"
        objarea = objarea * xbilichi * ybilichi / 10 ^ 10 * 15
    Else
        danwei = "K㎡"
        objarea = objarea * xbilichi * ybilichi / 10 ^ 12
    End If
    Dim geshi As String
   
    geshi = "0." & Right("00000", xiaoshuweishu)
    Dim mianjitext As AcadText
    Set mianjitext = ThisDrawing.ModelSpace.AddText("面积=" & Format(objarea, geshi) & danwei, basepoint, zigao)
    mianjitext.color = acGreen
    mianyu.color = acRed '红色显示多段线
'    ThisDrawing.Regen acActiveViewport
'    ThisDrawing.Application.Update
    Dim groupobj As AcadGroup '定义组对象
    Dim appendobjs(0 To 1) As AcadEntity
    Set appendobjs(0) = mianjitext
    Set appendobjs(1) = mianyu
    Set groupobj = ThisDrawing.Groups.Add("*")
    groupobj.AppendItems appendobjs
ee1:
    If Err.Number <> 0 Then
        '如果按了空格 或是回车 或是出现了其他错误
        'MsgBox Err.Description
        Me.show
        Err.Clear
        '恢复文字样式
        ThisDrawing.SetVariable "textstyle", currenttextstyle
        ThisDrawing.SetVariable "osmode", currentosmode
        'ThisDrawing.ObjectSnapMode = True '打开对象捕捉
        '恢复图层
        ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
        ThisDrawing.SendCommand "ucs" & vbCr & "p" & vbCr
        Exit Sub
    Else
        GoTo r1
    End If
    '恢复文字样式
    ThisDrawing.SetVariable "textstyle", currenttextstyle
    ThisDrawing.SetVariable "osmode", currentosmode
    'ThisDrawing.ObjectSnapMode = True '打开对象捕捉
    '恢复图层
    ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
    'ThisDrawing.SendCommand "REGEN" & vbCr
    '恢复上一个坐标系
    ThisDrawing.SendCommand "ucs" & vbCr & "p" & vbCr
End Sub


Private Sub CommandButton4_Click() '框选对象进行分类统计
    Me.Hide
    zigao = ComboBox1.Text
    xbilichi = ComboBox2.Text
    ybilichi = ComboBox4.Text
    xiaoshuweishu = ComboBox3.Text
    On Error Resume Next
    quxiao '调用取消命令
    currenttextstyle = ThisDrawing.GetVariable("textstyle")
    currentlayername = ThisDrawing.ActiveLayer.name
    Set arealayer = ThisDrawing.Layers.Add("面积统计")
    arealayer.color = acGreen
    ThisDrawing.SetVariable "cecolor", "256"
    With arealayer
        .LayerOn = True
        .Lock = False
        .Freeze = False
    End With
    ThisDrawing.ActiveLayer = arealayer
    Dim sset1 As AcadSelectionSet
    Dim filtertype(9) As Integer '定义选择过滤器类型的dsf组码
    Dim filterdata(9) As Variant '定义过滤器的值
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "CIRCLE"
    filtertype(2) = 0
    filterdata(2) = "ARC"
    filtertype(3) = 0
    filterdata(3) = "SPLINE"
    filtertype(4) = 0
    filterdata(4) = "lwpolyline"
    filtertype(5) = 0
    filterdata(5) = "POLYLINE"
    filtertype(6) = 0
    filterdata(6) = "REGION"  '面域对象
    filtertype(7) = 0
    filterdata(7) = "HATCH"  '填充对象  填充的面积属性在 2006 版本中支持 Hatch 对象
    filtertype(8) = 0
    filterdata(8) = "ellipse" '椭圆对象
    filtertype(9) = -4
    filterdata(9) = "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 layermianji(ThisDrawing.Layers.count - 1)
   
    Dim mianjiobj As AcadObject
    For i = 0 To ThisDrawing.Layers.count - 1
        For Each mianjiobj In sset1
            If ThisDrawing.Layers.Item(i).name = mianjiobj.Layer Then
                layermianji(i) = layermianji(i) + mianjiobj.Area
            End If
        Next
        If layermianji(i) <> 0 Then  '记录面积不为零的图层个数
            j = j + 1
        End If
    Next
'    If j = 0 Then
'        Me.Show
'        Exit Sub
'    End If
    ReDim mianjitongji(0 To j - 1)
    Dim jj As Integer
    For i = 0 To ThisDrawing.Layers.count - 1
        If layermianji(i) <> 0 Then
            mianjitongji(jj).name = ThisDrawing.Layers.Item(i).name
            mianjitongji(jj).summianji = layermianji(i)
            jj = jj + 1
        End If
    Next
    allmianji = 0


    For i = 0 To UBound(mianjitongji)
        If OptionButton1.value Then
            mianjitongji(i).summianji = mianjitongji(i).summianji * xbilichi * ybilichi / 10 ^ 6
        ElseIf OptionButton4.value Then
            mianjitongji(i).summianji = mianjitongji(i).summianji * xbilichi * ybilichi / 10 ^ 10 * 15
        Else
            mianjitongji(i).summianji = mianjitongji(i).summianji * xbilichi * ybilichi / 10 ^ 12
        End If
        allmianji = allmianji + mianjitongji(i).summianji  '求总面积
    Next
   
    If OptionButton1.value Then
        danwei = "㎡"
    ElseIf OptionButton4.value Then
        danwei = "亩"
    Else
        danwei = "K㎡"
    End If
    Dim basepoint As Variant
    basepoint = ThisDrawing.Utility.GetPoint(, "拾取统计表格插入点:")
   
    '画统计表格
    newtextstyle1    '调用新建字体样式程序
    ThisDrawing.SetVariable "textstyle", "wh_lkx1"
   
    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) + 4 * biaotoukuan: p1p2(3) = p1p2(1)
    ThisDrawing.ModelSpace.AddLightWeightPolyline p1p2
    p1p2(0) = basepoint(0): p1p2(1) = basepoint(1) - biaotougao
    p1p2(2) = basepoint(0) + 4 * biaotoukuan: p1p2(3) = p1p2(1)
    ThisDrawing.ModelSpace.AddLightWeightPolyline p1p2
   
    For i = 0 To UBound(mianjitongji)
        p1p2(0) = basepoint(0): p1p2(1) = p1p2(1) - biaotougao
        p1p2(2) = basepoint(0) + 4 * biaotoukuan: p1p2(3) = p1p2(1)
        ThisDrawing.ModelSpace.AddLightWeightPolyline p1p2
    Next
    For i = 0 To 4
        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) + 4 * 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
   
    '插入序号和单位
    For i = 1 To UBound(mianjitongji) + 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(mianjitongji) + 1
        charudian(0) = basepoint(0) + biaotoukuan * 3.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
    charudian(1) = basepoint(1) - (i + 0.5) * biaotougao
   
    Set mingcheng = ThisDrawing.ModelSpace.AddText( _
                        "对象个数:" & sset1.count & "。  " & _
                        "总面积=" & Format(allmianji, geshi) & danwei, charudian, zigao)
    mingcheng.Alignment = acAlignmentMiddleCenter
    mingcheng.TextAlignmentPoint = charudian
   
    '插入图层名称和面积数据
    For i = 1 To UBound(mianjitongji) + 1
        charudian(0) = basepoint(0) + biaotoukuan * 1.5
        charudian(1) = basepoint(1) - (i + 0.5) * biaotougao
        Set mingcheng = ThisDrawing.ModelSpace.AddText(mianjitongji(i - 1).name, charudian, zigao)
        mingcheng.Alignment = acAlignmentMiddleCenter
        mingcheng.TextAlignmentPoint = charudian
    Next
    For i = 1 To UBound(mianjitongji) + 1
        charudian(0) = basepoint(0) + biaotoukuan * 2.5
        charudian(1) = basepoint(1) - (i + 0.5) * biaotougao
        Set mingcheng = ThisDrawing.ModelSpace.AddText(Format(mianjitongji(i - 1).summianji, 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("当前图形比例尺  x方向：1:" & xbilichi _
                                                              & "  y方向：1:" & ybilichi, charudian, zigao)
   
    '恢复文字样式
    ThisDrawing.SetVariable "textstyle", currenttextstyle
    '恢复图层
    ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
   
    sset1.Clear
    sset1.Delete
    Me.show
End Sub
Private Sub UserForm_Initialize()
    'quxiao '调用取消命令
    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
    ComboBox2.AddItem 4000000
   
    For i = 0 To 23 '设置当前图形垂直比例
        ComboBox4.AddItem ComboBox2.List(i)
    Next
    ComboBox3.AddItem 1 '设置小数位数
    ComboBox3.AddItem 2
    ComboBox3.AddItem 3
    ComboBox3.AddItem 4
    ComboBox3.AddItem 5
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

xj6019

大佬厉害呀，分享这么多

664571221

大哥怎么最近公布了这么多源码呀

woxing1987

664571221 发表于 2022-2-10 10:57
大哥怎么最近公布了这么多源码呀

希望能对明经好友有一些帮助吧

woxing1987

xj6019 发表于 2022-2-9 16:00
大佬厉害呀，分享这么多

希望能对你有些帮助

czb203

大哥怎么最近公布了这么多源码呀

yuan4399

怎么用呀