沙漠骆驼工具箱源码-5长度统计
工具条：长度统计，界面和代码如下：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
页:
[1]