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

0 Members and 1 Guest are viewing this topic.

#### rkmcswain ##### 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]

#### rkmcswain ##### 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: 1851 ##### 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 ExplicitConst PI As Double = 3.14159265358979Sub 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 SubFunction 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 FunctionPrivate 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 FunctionPrivate 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 FunctionFunction Rd(num1 As Variant, num2 As Variant) As Boolean    Dim dRet As Double    dRet = num1 - num2    If Abs(dRet) < 0.00000001 Then Rd = TrueEnd FunctionPublic 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 IfEnd FunctionPublic 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 FunctionPublic 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 IfEnd FunctionFunction 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`