Attribute VB_Name = "ThisDrawing"
Attribute VB_Base = "0{7AABBB95-79BE-4C0F-8024-EB6AF271231C}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
'ȡֱߣisline ʱ20170022:14:13
'pline,ispline
'߶ϱע
    Dim podu As Double, str As String, str2 As String, texthight As Double
    Dim diameter As Integer, heightA As Integer, heightB As Integer 'ܾ϶˸̣߳¶˸߳
Sub bzpd()
    Dim pickbox1 As Integer, scmde As Integer
    Dim layerobj As AcadLayer
    Dim currentlayername As String
    Dim currentcolor As String
    Dim currenttextstyle As String
    currentlayername = ThisDrawing.ActiveLayer.Name
    currentcolor = ThisDrawing.GetVariable("cecolor")
    Set layerobj = ThisDrawing.Layers.Add("עֶ̰߳棩")
    currenttextstyle = ThisDrawing.GetVariable("textstyle")
    layerobj.color = acGreen
    ThisDrawing.ActiveLayer = layerobj
    newtextstyle    '½ʽ
    pickbox1 = ThisDrawing.GetVariable("pickbox")
    scmde = ThisDrawing.GetVariable("cmdecho")
    ThisDrawing.SetVariable "pickbox", 7
    ThisDrawing.SetVariable "cmdecho", 0
    ThisDrawing.SetVariable "textstyle", "wh_lkx"
    On Error Resume Next
    texthight = 1
    diameter = 1
    heightA = 1
    heightB = 1
    texthight = ThisDrawing.Utility.GetReal("ָ(1)")
        If texthight = Null Or texthight <= 0 Then texthight = 1
    diameter = ThisDrawing.Utility.GetInteger("ܾd:")
        If diameter = Null Or diameter <= 0 Then diameter = 0
    heightA = ThisDrawing.Utility.GetInteger("϶:")
        If heightA = Null Or heightA <= 0 Then heightA = 0
    heightB = ThisDrawing.Utility.GetInteger("¶˸߳:")
        If heightB = Null Or heightB <= 0 Then heightB = 0
    bzpdprograme   'ñע¶ȳ
    'ϵͳ
    With ThisDrawing
        .SetVariable "pickbox", 3
        .SetVariable "cmdecho", 0
        .SetVariable "cecolor", currentcolor 'ָͼɫ
        .SetVariable "textstyle", "standard"
    End With
    'ָͼ
    ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
End Sub
Private Sub bzpdprograme()
    Dim lineobj As AcadLine
    Dim plineobj As AcadLWPolyline
    Dim returnobj As AcadObject
    Dim basepnt As Variant
    'Dim p1(0 To 2) As Single
    'Dim p2(0 To 2) As Single
    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
e1:
    If Err.Number <> 0 Then  ' -2147352567
        '˿ո ǻس ǳ󣬱Ϊ0
        ThisDrawing.Application.Update
        Exit Sub
    Else
        GoTo r1
    End If
End Sub
Private Sub isline(p1 As Variant, p2 As Variant) 'ֱ߹ܵע
    podu = Abs(heightA - heightB) '߲
        str = "d" & Format(diameter) & " L=" & Format(distance(p1, p2), "0.00") & "m i=" & Format(Abs((heightA - heightB) / distance(p1, p2) * 100), "0.00") & "%" 'Ѿ
            If (heightA - heightB) < 0 Then
         str2 = "--------"
         Else
         str2 = "--------"
         End If
    'outpodu ̣Ļ
    outpodu str, p1, p2, angle(p1, p2), texthight
    outpodu2 str2, p1, p2, angle(p1, p2), texthight
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                       '߲Ǳպϵ
        podu = Abs(heightA - heightB) '߲
        str = "d" & Format(diameter) & " L=" & Format(distance(p1, p2), "0.00") & "m i=" & Format(Abs((heightA - heightB) / distance(p1, p2) * 100), "0.00") & "%" 'Ѿ
                If (heightA - heightB) < 0 Then
         str2 = "--------"
         Else
         str2 = "--------"
         End If
        'outpodu ̣עĻ
        outpodu str, p1, p2, angle2, texthight
        outpodu2 str2, p1, p2, angle2, texthight
    Else                                   'Ǳպϵ
        p1(0) = plineobj.Coordinate(0)(0)
        p1(1) = plineobj.Coordinate(0)(1)
        podu = Abs(heightA - heightB) '߲
        str = "d" & Format(diameter) & " L=" & Format(distance(p1, p2), "0.00") & "m i=" & Format(Abs((heightA - heightB) / distance(p1, p2) * 100), "0.00") & "%" 'Ѿ
                If (heightA - heightB) < 0 Then
         str2 = "--------"
         Else
         str2 = "--------"
         End If
        'outpodu ̣עĻ
        outpodu str, p1, p2, angle(p1, p2), texthight
        outpodu2 str2, p1, p2, angle(p1, p2), texthight
    End If
End Sub
'߶мַ
Private Sub outpodu(str As String, p1 As Variant, p2 As Variant, 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.1415926
End Sub
'߶мַ2
Private Sub outpodu2(str2 As String, p1 As Variant, p2 As Variant, angle As Double, texthight As Double)
    Dim pt(0 To 2) As Double
    Dim textobj As AcadText
    pt(0) = (p1(0) + p2(0)) / 2 - 1.3
    pt(1) = (p1(1) + p2(1)) / 2 - 1.3
    Set textobj = ThisDrawing.ModelSpace.AddText(str2, pt, texthight)
    With textobj
        .Alignment = acAlignmentBottomCenter
        .TextAlignmentPoint = pt
        .Rotation = angle
    End With
    If p1(0) >= p2(0) Then textobj.Rotation = angle + 3.1415926
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 = (dx / dy)
End Function
'Ƕ  ʽǻ
Function angle(p1 As Variant, p2 As Variant) As Double
    angle = ThisDrawing.Utility.AngleFromXAxis(p1, p2)
End Function
 'µʽ
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
    'lkxtextstyle.SetFont "", Bold, Italic, charSet, PitchandFamily
    'lkxtextstyle.Width = 0.8  'ÿȱ
    'ThisDrawing.ActiveTextStyle = lkxtextstyle
End Sub

