沙漠骆驼工具箱源码-12查询及桩号(纵断面)
工具条：查询及桩号，界面和代码如下：1 界面：
2 代码如下：
Option Explicit '要求变量声明
Dim zigao As Single '字体高度
Dim xscale As Double '设置垂直比例
Dim basepoint As Variant
Dim jianqieban As New DataObject
Dim jizhunzh As Double '定义基准桩号
Dim geshi As String
Private Sub ComboBox2_Change()
xscale = ComboBox2.Text
Label11.Caption = xscale
End Sub
Private Sub CommandButton1_Click()'拾取或修改桩号基准 jizhunzh
Me.Hide
On Error Resume Next
zigao = ComboBox1.Text
xscale = ComboBox2.Text
ThisDrawing.SetVariable "textstyle", "wh_lkx"
basepoint = ThisDrawing.Utility.GetPoint(, "请拾取桩号基准点:")
If Err.Number <> 0 Then
ThisDrawing.Utility.prompt "-----桩号基准点拾取失败------" & vbCrLf
Me.show
Err.Clear
Exit Sub
End If
ThisDrawing.Utility.prompt "请输入桩号基准值(默认为0)：" & vbCrLf
jizhunzh = ThisDrawing.Utility.GetReal()
geshi = "0+000.000"
If jizhunzh = Int(jizhunzh) Then geshi = "0+000"
Label10.Caption = Format(jizhunzh, geshi)
Label11.Caption = xscale
Me.height = 227
Me.show
End Sub
Private Sub CommandButton2_Click() '显示任意一点桩号
Me.Hide
Dim charudian1 As Variant
Dim xianshidian As AcadCircle
On Error GoTo e1
Dim linshidian(0 To 2) As Double
linshidian(0) = 0: linshidian(1) = 0: linshidian(2) = 0
Set xianshidian = ThisDrawing.ModelSpace.AddCircle(linshidian, zigao) '先随便画一个圆，一个小小的技巧
r1:
charudian1 = ThisDrawing.Utility.GetPoint(, "拾取任意一点:")
xianshidian.Delete
Set xianshidian = ThisDrawing.ModelSpace.AddCircle(charudian1, zigao)
xianshidian.color = acRed
xianshidian.Highlight True
Dim renyizhuanghao As Double
renyizhuanghao = jizhunzh + (charudian1(0) - basepoint(0)) * xscale / 1000
'ThisDrawing.Utility.Prompt "-----该点桩号为：" & Format(renyibiaogao, "0.000") & " 米-----" & vbCrLf
geshi = "0+000.000"
If renyizhuanghao = Int(renyizhuanghao) Then geshi = "0+000"
ThisDrawing.ModelSpace.AddText Format(renyizhuanghao, geshi), charudian1, zigao
'复制到剪切板上
jianqieban.SetText Format(renyizhuanghao, geshi)
jianqieban.PutInClipboard
ThisDrawing.Utility.prompt "-----该点桩号已经复制到剪切板上-----" & vbCrLf
e1:
If Err.Number <> 0 Then
Err.Clear
Me.show
xianshidian.Delete
Exit Sub
Else
GoTo r1
End If
End Sub
Private Sub CommandButton3_Click()
Me.Hide
End Sub
Private Sub CommandButton4_Click() '查询任一点桩号
Me.Hide
Dim charudian1 As Variant
Dim xianshidian As AcadCircle
On Error GoTo e1
Dim linshidian(0 To 2) As Double
linshidian(0) = 0: linshidian(1) = 0: linshidian(2) = 0
Set xianshidian = ThisDrawing.ModelSpace.AddCircle(linshidian, zigao)
r1:
charudian1 = ThisDrawing.Utility.GetPoint(, "拾取任意一点:")
xianshidian.Delete
Set xianshidian = ThisDrawing.ModelSpace.AddCircle(charudian1, zigao)
xianshidian.color = acRed
xianshidian.Highlight True
Dim renyizhuanghao As Double
renyizhuanghao = jizhunzh + (charudian1(0) - basepoint(0)) * xscale / 1000
geshi = "0+000.000"
If renyizhuanghao = Int(renyizhuanghao) Then geshi = "0+000"
ThisDrawing.Utility.prompt "-----该点桩号为：" & Format(renyizhuanghao, geshi) & " 米-----" & vbCrLf
'复制到剪切板上
jianqieban.SetText Format(renyizhuanghao, geshi)
jianqieban.PutInClipboard
ThisDrawing.Utility.prompt "-----该点桩号已经复制到剪切板上-----" & vbCrLf
'ThisDrawing.ModelSpace.AddText Format(renyibiaogao, "0.000"), charudian1, zigao
e1:
If Err.Number <> 0 Then
Err.Clear
Me.show
xianshidian.Delete
Exit Sub
Else
GoTo r1
End If
End Sub
Private Sub CommandButton5_Click() '插入给定的桩号
Me.Hide
Dim zhuanghaozhi As Double
Dim charudian1 As Variant
Dim xianshidian As AcadCircle
On Error GoTo e1
Dim linshidian(0 To 2) As Double
linshidian(0) = 0: linshidian(1) = 0: linshidian(2) = 0
Set xianshidian = ThisDrawing.ModelSpace.AddCircle(linshidian, 1) '先随便画一个圆，一个小小的技巧
r1:
zhuanghaozhi = ThisDrawing.Utility.GetReal("请输入桩号:")
charudian1 = ThisDrawing.Utility.GetPoint(, "请拾取桩号插入点:")
charudian1(0) = basepoint(0) + (zhuanghaozhi - jizhunzh) * 1000 / xscale
charudian1(2) = 0
'ThisDrawing.Utility.Prompt "-----该点桩号为：" & Format(renyibiaogao, "0.000") & " 米-----" & vbCrLf
geshi = "0+000.000"
If zhuanghaozhi = Int(zhuanghaozhi) Then geshi = "0+000"
ThisDrawing.ModelSpace.AddText Format(zhuanghaozhi, geshi), charudian1, zigao
ThisDrawing.ModelSpace.AddCircle charudian1, zigao / 3
xianshidian.Delete
Set xianshidian = ThisDrawing.ModelSpace.AddCircle(charudian1, zigao)
xianshidian.color = acRed
xianshidian.Highlight True
'跳到插入点并最大化显示
Dim zuoxiadian As Variant
Dim youshangdian As Variant
xianshidian.GetBoundingBox zuoxiadian, youshangdian
zuoxiadian(0) = zuoxiadian(0) - 20
youshangdian(0) = youshangdian(0) + 20
ThisDrawing.Application.ZoomWindow zuoxiadian, youshangdian
e1:
If Err.Number <> 0 Then
Err.Clear
Me.show
xianshidian.Delete
Exit Sub
Else
GoTo r1
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 '设置水平比例1-500000
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
Me.height = 96
newtextstyle2 '调用新建字体样式程序
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
谢谢群主分享
页:
[1]