沙漠骆驼工具箱源码-8坡度标注

woxing1987

工具条：坡度标注，界面和代码如下：
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

czb203

谢谢楼主分享