Author Topic: Distance along polyline between two points  (Read 2308 times)

0 Members and 1 Guest are viewing this topic.

rkmcswain

  • Swamp Rat
  • Posts: 952
Distance along polyline between two points
« on: October 31, 2007, 03:59:45 PM »
Of course in lisp, you can use vlax-curve-getDistAtPoint.

Any recent developments on how to do this in VBA?   :-(

TIA

LE

  • Guest
Re: Distance along polyline between two points
« Reply #1 on: October 31, 2007, 04:48:57 PM »
If you remember Frank Oquendo.... he wrote something named VLAX Curve class for those still in VBA

Here is a short cut to grab it: [more hint it is a zip file] [and.... hth]
http://discussion.autodesk.com/thread.jspa?threadID=502098

rkmcswain

  • Swamp Rat
  • Posts: 952
Re: Distance along polyline between two points
« Reply #2 on: November 01, 2007, 10:28:14 AM »
Thanks LE. Works great.


Bryco

  • Water Moccasin
  • Posts: 1850
Re: Distance along polyline between two points
« Reply #3 on: November 04, 2007, 11:31:27 AM »
Here's a Vba way, it was a little harder to do this than I thought as I already had it's mate, getting the point at distance.
Code: [Select]
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 ccw
            bOnArc = True
        End If
    Else
        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) Then
                isOnLine = True
            End If
        Else
            If Pt(XY) >= C2(XY) And Pt(XY) <= C1(XY) Then
                isOnLine = True
            End If
        End If
        Exit Function
               
    Else
       
        X = (Pt(0) - C1(0)) / deltaX
        If X >= -0.0000001 Then
            If X <= 1.0000001 Then
                Y = (Pt(1) - C1(1)) / deltaY
                If Y >= -0.0000001 And Y <= 1.0000001 Then
                    isOnLine = True
                End If
            End If
        End If
       
    End If
   
End Function



Function Rd(num1 As Variant, num2 As Variant) As Boolean
    Dim dRet As Double
    dRet = num1 - num2
    If Abs(dRet) < 0.00000001 Then Rd = True
End Function






Public Function Length(StartPoint As Variant, EndPoint As Variant) As Double

    Dim Stx As Double, Sty As Double, Stz As Double
    Dim Enx As Double, Eny As Double, Enz As Double
    Dim dX As Double, dY As Double, dZ As Double
    Dim i As Integer
    If IsEmpty(StartPoint) Then Err.Raise 13
    i = UBound(StartPoint)
    If UBound(EndPoint) = i Then
        If i > 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