沙漠骆驼工具箱源码-8坡度标注
工具条:坡度标注,界面和代码如下:1 界面:
2代码如下
Dim podu As Double, str As String, texthight As Double
Dim xscale As Double, yscale As Double '定义x方向比例,y方向比例
Private Sub CommandButton1_Click() '单选对象进行坡度标注
Me.Hide
ThisDrawing.SendCommand "wh_lkx" & vbCr
texthight = ComboBox1.Text
xscale = ComboBox3.Text
yscale = ComboBox2.Text
Dim pickbox1 As Integer
Dim layerobj As AcadLayer
Dim currentlayername As String
Dim currentcolor As String
Dim currenttextstyle As String
On Error Resume Next
currentlayername = ThisDrawing.ActiveLayer.name
currentcolor = ThisDrawing.GetVariable("cecolor")
Set layerobj = ThisDrawing.Layers.Add("坡度标注")
currenttextstyle = ThisDrawing.GetVariable("textstyle")
layerobj.color = acGreen
ThisDrawing.SetVariable "cecolor", "256"
ThisDrawing.ActiveLayer = layerobj
newtextstyle2 '调用新建字体样式程序
pickbox1 = ThisDrawing.GetVariable("pickbox")
ThisDrawing.SetVariable "pickbox", 5
ThisDrawing.SetVariable "cmdecho", 0
ThisDrawing.SetVariable "textstyle", "wh_lkx"
bzpdprograme '调用标注坡度程序
'重置系统变量
With ThisDrawing
.SetVariable "pickbox", pickbox1
.SetVariable "cmdecho", 0
.SetVariable "cecolor", currentcolor '恢复绘图颜色
.SetVariable "textstyle", currenttextstyle
End With
'恢复图层
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
Me.show
'ThisDrawing.SendCommand "vbarun" & vbCr
End Sub
Private Sub CommandButton2_Click()
Me.Hide
End Sub
Private Sub CommandButton3_Click() '框选对象进行坡度标注
Me.Hide
ThisDrawing.SendCommand "wh_lkx" & vbCr
texthight = ComboBox1.Text
xscale = ComboBox3.Text
yscale = ComboBox2.Text
Dim pickbox1 As Integer
Dim layerobj As AcadLayer
Dim currentlayername As String
Dim currentcolor As String
Dim currenttextstyle As String
On Error Resume Next
currentlayername = ThisDrawing.ActiveLayer.name
currentcolor = ThisDrawing.GetVariable("cecolor")
Set layerobj = ThisDrawing.Layers.Add("坡度标注")
currenttextstyle = ThisDrawing.GetVariable("textstyle")
layerobj.color = acGreen
ThisDrawing.SetVariable "cecolor", "256"
ThisDrawing.ActiveLayer = layerobj
newtextstyle2 '调用新建字体样式程序
pickbox1 = ThisDrawing.GetVariable("pickbox")
ThisDrawing.SetVariable "pickbox", 5
ThisDrawing.SetVariable "cmdecho", 0
ThisDrawing.SetVariable "textstyle", "wh_lkx"
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 explodedObjects As Variant '存储炸开后的直线
Dim i As Double
Dim j As Double
For i = 0 To sset1.count - 1
If sset1.Item(i).ObjectName = "AcDbLine" Then
isline sset1.Item(i).startpoint, sset1.Item(i).endpoint '调用直线坡度标注
Else
explodedObjects = sset1.Item(i).Explode
For j = 0 To UBound(explodedObjects)
isline explodedObjects(j).startpoint, explodedObjects(j).endpoint '调用直线坡度标注
explodedObjects(j).Delete
Next
End If
Next
'重置系统变量
With ThisDrawing
.SetVariable "pickbox", pickbox1
.SetVariable "cmdecho", 0
.SetVariable "cecolor", currentcolor '恢复绘图颜色
.SetVariable "textstyle", currenttextstyle
End With
'恢复图层
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
Me.show
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
ComboBox2.AddItem 300
ComboBox3.AddItem 1 '设置水平比例
ComboBox3.AddItem 2
ComboBox3.AddItem 5
ComboBox3.AddItem 10
ComboBox3.AddItem 20
ComboBox3.AddItem 25
ComboBox3.AddItem 50
For i = 3 To 6
ComboBox3.AddItem 10 * ComboBox3.List(i)
Next
For i = 3 To 6
ComboBox3.AddItem 100 * ComboBox3.List(i)
Next
For i = 3 To 6
ComboBox3.AddItem 1000 * ComboBox3.List(i)
Next
End Sub
Private Sub bzpdprograme()'单选对象时调用
' Dim lineobj As AcadLine
' Dim plineobj As AcadLWPolyline
' Dim returnobj As AcadObject
' Dim basepnt As Variant
' On Error GoTo e1
'r1:
' ThisDrawing.Utility.GetEntity returnobj, basepnt, "请拾取直线或多段线,且不水平或垂直(退出):"
' If returnobj.ObjectName = "AcDbLine" Then
' Set lineobj = returnobj
' isline lineobj.startpoint, lineobj.endpoint '调用直线坡度标注
' ElseIf returnobj.ObjectName = "AcDbPolyline" Then
' Set plineobj = returnobj
' ispline plineobj, basepnt
' End If
' Err.Clear
'e1:
' If Err.Number <> 0 Then' -2147352567
' '如果按了空格 或是回车 或是出现了其他错误,比如除数为0
' ThisDrawing.Application.Update
' Err.Clear
' Exit Sub
' Else
' GoTo r1
' End If
'用 do while loop语句 进行循环
Dim lineobj As AcadLine
Dim plineobj As AcadLWPolyline
Dim returnobj As AcadObject
Dim basepnt As Variant
On Error GoTo e1
Do While 1
ThisDrawing.Utility.GetEntity returnobj, basepnt, "请拾取直线或多段线(退出):"
If returnobj.ObjectName = "AcDbLine" Then
Set lineobj = returnobj
isline lineobj.startpoint, lineobj.endpoint '调用直线坡度标注
ElseIf returnobj.ObjectName = "AcDbPolyline" Then
Set plineobj = returnobj
ispline plineobj, basepnt
End If
Err.Clear
Loop
e1:
'如果按了空格 或是回车 或是出现了其他错误,比如除数为0
'添加一个取消命令
Err.Clear
Exit Sub
End Sub
Private Sub isline(ByVal p1 As Variant, ByVal p2 As Variant) '直线坡度标注
If p1(0) = p2(0) Then
outpodu "垂直", p1, p2, 3.14159265359 / 2, texthight
ElseIf p1(1) = p2(1) Then
outpodu "水平", p1, p2, 0, texthight
Else
podu = tanangle(p1, p2) * xscale / yscale '计算x方向,y方向比例尺之后的坡度
If OptionButton1.value Then str = "1:" & Format(podu, "0.000") '已经计算出坡度了
If OptionButton2.value Then str = Format(1 / podu, "0.000")
If OptionButton3.value Then str = Format(1 / podu, "0.0%")
'调用outpodu 过程,输出坡度倒屏幕上
outpodu str, p1, p2, angle(p1, p2), texthight
End If
End Sub
'如果点取的是多段线,参数是多段线对象和拾取点
Private Sub ispline(plineobj As AcadObject, pt As Variant)
Dim p1(0 To 2) As Double, p2(0 To 2) As Double
Dim count As Integer, i As Integer 'i是多段线的线段索引编号
Dim d1 As Double, d2 As Double, d3 As Double
Dim angle1 As Double, angle2 As Double
count = UBound(plineobj.Coordinates) \ 2
For i = 0 To count - 1
d1 = distance(plineobj.Coordinate(i), pt)
d2 = distance(pt, plineobj.Coordinate(i + 1))
d3 = distance(plineobj.Coordinate(i), plineobj.Coordinate(i + 1))
'MsgBox d1 & Chr(13) & d2 & Chr(13) & d1 + d2 & Chr(13) & d3
p1(0) = plineobj.Coordinate(i)(0)
p1(1) = plineobj.Coordinate(i)(1)
p2(0) = plineobj.Coordinate(i + 1)(0)
p2(1) = plineobj.Coordinate(i + 1)(1)
angle1 = ThisDrawing.Utility.AngleFromXAxis(p1, pt)
angle2 = ThisDrawing.Utility.AngleFromXAxis(p1, p2)
angle1 = angle(p1, pt)
angle2 = angle(p1, p2)
'MsgBox angle1 & Chr(13) & angle2
If Abs((d1 + d2 - d3) / d3) < 0.01 Then
Exit For
End If
Next
'已经确定拾取的点在多段线的哪个位置,i是多段线的线段索引编号
'MsgBox i
'MsgBox count
If i < count Then '多段线不是闭合的
If p1(0) = p2(0) Then
outpodu "垂直", p1, p2, 3.14159265359 / 2, texthight
ElseIf p1(1) = p2(1) Then
outpodu "水平", p1, p2, 0, texthight
Else
podu = tanangle(p1, p2) * xscale / yscale '计算x方向,y方向比例尺之后的坡度
If OptionButton1.value Then str = "1:" & Format(podu, "0.000") '已经计算出坡度了
If OptionButton2.value Then str = Format(1 / podu, "0.000")
If OptionButton3.value Then str = Format(1 / podu, "0.0%")
'调用outpodu 过程,输出坡度倒屏幕上
outpodu str, p1, p2, angle2, texthight
End If
Else '多段线是闭合的
p1(0) = plineobj.Coordinate(0)(0)
p1(1) = plineobj.Coordinate(0)(1)
If p1(0) = p2(0) Then
outpodu "垂直", p1, p2, 3.14159265359 / 2, texthight
ElseIf p1(1) = p2(1) Then
outpodu "水平", p1, p2, 0, texthight
Else
podu = tanangle(p1, p2) * xscale / yscale'计算x方向,y方向比例尺之后的坡度
If OptionButton1.value Then str = "1:" & Format(podu, "0.000") '已经计算出坡度了
If OptionButton2.value Then str = Format(1 / podu, "0.000")
If OptionButton3.value Then str = Format(1 / podu, "0.0%")
'调用outpodu 过程,输出坡度倒屏幕上
outpodu str, p1, p2, angle(p1, p2), texthight
End If
End If
End Sub
'在线段中间标上字符
Private Sub outpodu(ByVal str As String, ByVal p1 As Variant, ByVal p2 As Variant, ByVal angle As Double, texthight As Double)
Dim pt(0 To 2) As Double
Dim textobj As AcadText
pt(0) = (p1(0) + p2(0)) / 2
pt(1) = (p1(1) + p2(1)) / 2
Set textobj = ThisDrawing.ModelSpace.AddText(str, pt, texthight)
With textobj
.Alignment = acAlignmentBottomCenter
.TextAlignmentPoint = pt
.Rotation = angle
End With
If p1(0) >= p2(0) Then textobj.Rotation = angle + 3.14159265359
End Sub
'求两点之间的距离
Function distance(sp As Variant, ep As Variant) As Double
Dim dx As Double, dy As Double, dz As Double
dx = sp(0) - ep(0)
dy = sp(1) - ep(1)
'dz = sp(2) - ep(2)
distance = Sqr(dx ^ 2 + dy ^ 2)
End Function
'计算dx,dy 求坡度 dx/dy,输入起点坐标sp 和终点坐标根据ep
Function tanangle(sp As Variant, ep As Variant) As Double
Dim dx As Single, dy As Single, dz As Single
dx = sp(0) - ep(0)
dy = sp(1) - ep(1)
tanangle = Abs(dx / dy)
End Function
'计算角度格式是弧度
Function angle(ByVal p1 As Variant, ByVal p2 As Variant) As Double
angle = ThisDrawing.Utility.AngleFromXAxis(p1, p2)
End Function
'创建新的字体样式
Private Sub newtextstyle() '创建新的字体样式
Dim lkxtextstyle As AcadTextStyle
Set lkxtextstyle = ThisDrawing.TextStyles.Add("whlkx")
With lkxtextstyle
.fontFile = "simp1.shx"
.BigFontFile = "hz.shx"
.width = 0.7
End With
' 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
' 'lkxtextstyle.SetFont "宋体", Bold, Italic, charSet, PitchandFamily
' 'lkxtextstyle.Width = 0.8'设置宽度比例
' 'ThisDrawing.ActiveTextStyle = lkxtextstyle
End Sub
谢谢楼主分享
页:
[1]