沙漠骆驼工具箱源码-9 桩号标注
工具条：桩号标注，界面和代码如下：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
沙漠骆驼工具箱源码-9 桩号标注感谢分享。。虽然看不懂 但是大佬的分享精神值得学习
页:
[1]