沿两点之间折线的距离

Option Explicit
Const PI As Double = 3.14159265358979
Sub TestPt()
    Dim oPline As AcadLWPolyline
    Dim Util As AcadUtility
    Dim Varpick As Variant
    
    Set Util = ThisDrawing.Utility
    Util.GetEntity oPline, Varpick, "Pick a poly:"
    Varpick = ThisDrawing.Utility.GetPoint(, "Point on poly")
    Debug.Print LengthAtPointOnPoly(oPline, Varpick)
    
End Sub
Function LengthAtPointOnPoly(oPline As AcadLWPolyline, Varpick As Variant) As Double
    Dim Dist As Double, TotalDist As Double
    Dim dBulge As Double, seg As Double
    Dim Pt(1) As Double
    Dim C1, C2
    Dim Ct As Integer, i As Long
    Dim Util As AcadUtility
    
    Set Util = ThisDrawing.Utility
    Varpick = Util.TranslateCoordinates(Varpick, acWorld, acOCS, False, oPline.Normal)
    If Not Rd(Varpick(2), oPline.Elevation) Then Exit Function
    Pt(0) = Varpick(0): Pt(1) = Varpick(1)
    Ct = (UBound(oPline.Coordinates) - 1) / 2
    If oPline.Closed = True Then Ct = Ct + 1
    ReDim Coords(Ct) As Variant
    For i = 0 To Ct - 1
        Coords(i) = oPline.Coordinate(i)
    Next
    If oPline.Closed = True Then
        Coords(Ct) = oPline.Coordinate(0)
    Else
        Coords(Ct) = oPline.Coordinate(Ct)
    End If
        
    For i = 0 To Ct - 1
        C1 = Coords(i)
        C2 = Coords(i + 1)
        dBulge = oPline.GetBulge(i)
        seg = Length(C1, C2)
        If dBulge = 0 Then
            If isOnLine(C1, C2, Pt) Then
                TotalDist = TotalDist + Length(C1, Pt)
                Exit For
            Else
                TotalDist = TotalDist + seg
                If i = Ct - 1 Then TotalDist = 0
            End If
         Else
            If isPtonArc(C1, C2, Pt, dBulge, seg, Dist) Then
                TotalDist = TotalDist + Dist
                Exit For
            Else
                TotalDist = TotalDist + polyarclength(dBulge, seg)
                If i = Ct - 1 Then TotalDist = 0
            End If
      
        End If
    Next i
    LengthAtPointOnPoly = TotalDist
    
End Function
Private Function isPtonArc(C1 As Variant, C2 As Variant, Pt As Variant, _
                dBulge As Double, seg As Double, Dist As Double) As Boolean
    Dim Rad As Double
    Dim X As Double, Y As Double
    Dim deltaX As Double, deltaY As Double
    Dim Slope As Double, Invertslope As Double
    Dim dLength As Double, AngX As Double
    Dim CenPt(1) As Double
    Dim bOnArc As Boolean
    Dim iLeft As Integer
    
    'IncludedAng = Atn(dBulge) * 4 'converting bulge to angle in radians
    Rad = seg / (2 * Sin(2 * Atn(dBulge)))
    'find the midpoint
    X = (C1(0) + C2(0)) / 2
    Y = (C1(1) + C2(1)) / 2
    deltaX = C2(0) - C1(0)
    deltaY = C2(1) - C1(1)
    'Convert floating point to zero
    If Rd(deltaX, 0) Then deltaX = 0
    If Rd(deltaY, 0) Then deltaY = 0
    
    'The height of the curve is dBulge * 0.5 * seg
    'dist is the length from the midpoint to the center
    Dist = Rad - dBulge * 0.5 * seg
    
    'If Abs(dBulge) > 1 Then Dist = -Dist
    
    If deltaY >= 0 Then
        If deltaX  0 Then
            Dist = -Dist
        End If
    Else
        If deltaX = 0 Then
            Dist = -Dist
        End If
    End If
                   
    If deltaY = 0 Then  'Line p1,p2 is horizontal
        CenPt(0) = X
        CenPt(1) = Y - Dist
    ElseIf deltaX = 0 Then 'Line p1,p2 is vertical
        CenPt(0) = X - Dist
        CenPt(1) = Y
    Else
        Slope = deltaY / deltaX
        Invertslope = -1 / Slope
        'Invert slope for perpendicular bisector
        'X = X1 + distance / dLength * DX
        'proving for   DeltaX=1 in slope direction
        'slope=DeltaY / 1 =>  DeltaY=slope
        dLength = Sqr(Invertslope ^ 2 + 1)
        CenPt(0) = X + (Dist / dLength) '* 1
        CenPt(1) = Y + ((Dist / dLength) * Invertslope)
    End If
    AddPt CenPt, , 1
    If Not Rd(Abs(Rad), Length(CenPt, Pt)) Then
        Exit Function
        'Point must be on a different segment
    End If
    
    iLeft = isLeft(C1, C2, Pt)
    
    If dBulge > 0 Then
        If iLeft  -1 Then 'On line (0) or cw
            bOnArc = True
        End If
    End If
    
    If bOnArc = True Then
        Dim C1pt As Double, incAng As Double
        C1pt = 0.5 * Length(C1, Pt)
        incAng = Abs(2 * ArcSin(C1pt / Rad))
        If Sgn(isLeft(C1, CenPt, Pt)) = Sgn(dBulge) Then
            incAng = 2 * PI - incAng
        End If
        Dist = Abs(incAng * Rad)
        isPtonArc = True
    End If
    
End Function
Private Function isOnLine(C1, C2, Pt) As Boolean
    Dim deltaX As Double, deltaY As Double
    Dim dLength As Double
    Dim XY As Integer
    Dim X As Double, Y As Double
    
    If isLeft(C1, C2, Pt)  0 Then Exit Function
    deltaX = C2(0) - C1(0)
    deltaY = C2(1) - C1(1)
    If Rd(deltaX, 0) Then deltaX = 0
    If Rd(deltaY, 0) Then deltaY = 0
      
    If deltaX = 0 Then XY = 0 'Line p1,p2 is vertical
    If deltaY = 0 Then XY = 1 'Line p1,p2 is horizontal
    
    If deltaX = 0 Or deltaY = 0 Then
        If C2(XY) > C1(XY) Then
            If Pt(XY) >= C1(XY) And Pt(XY) = C2(XY) And Pt(XY) = -0.0000001 Then
            If X = -0.0000001 And Y  0 Then
            Stx = StartPoint(0): Sty = StartPoint(1)
            Enx = EndPoint(0): Eny = EndPoint(1)
            dX = Stx - Enx
            dY = Sty - Eny
            If i = 1 Then
                Length = Sqr(dX * dX + dY * dY)
            Else
                Stz = StartPoint(2): Enz = EndPoint(2)
                dZ = Stz - Enz
                Length = Sqr((dX * dX) + (dY * dY) + (dZ * dZ))
            End If
        Else
            Exit Function
        End If
    Else
        Exit Function
    End If
End Function
Public Function polyarclength(Bulge As Double, LengthBetweenPts As Double) As Double
    'Bulge is the getbulge & LengthBetweenPts is the straight dist. between 2 verticies
    Dim dAng As Double, Dist As Double
    dAng = Atn(Bulge) * 4 'converting bulge to angle in radians
    Dist = 0.5 * LengthBetweenPts
    polyarclength = dAng * Dist / Sin(0.5 * dAng)
End Function
Public Function ArcSin(X) As Double
    If Abs(X > 1) Then
        MsgBox "Oops"
    End If
    If X = 1 Then
        ArcSin = PI * 0.5
    ElseIf X = -1 Then
        ArcSin = -PI * 0.5
    Else
        ArcSin = Atn(X / Sqr(-X * X + 1))
    End If
End Function
Function isLeft(LineStart, LineEnd, Pt) As Integer
    Dim Ans As Double
    Ans = ((LineEnd(0) - LineStart(0)) * (Pt(1) - LineStart(1)) _
            - (Pt(0) - LineStart(0)) * (LineEnd(1) - LineStart(1)))
    Ans = Round(Ans, 12)
    If Ans > 0 Then isLeft = 1: Exit Function  'Pt is left of the line  (CW)
    If Ans < 0 Then isLeft = -1: Exit Function  'Pt is right of the line (CCW)
    If Ans = 0 Then isLeft = 0
    
End Function