Iintersecting polyline with a circle

[BIGAL]

I need to calculate a point along a polyline based on intersecting a point of a circle with a polyline the centre is always along the poly line but can intersect different segments.

The idea is to walk along the poly line calculating the other points.

I have written a VBA`routine which calcs points along the poly line but I am looking for an easy way to calculate the intersecting points.


Any one done something like this ?

[ASMI]

See IntersectWith Method.

[fixo]

I need to calculate a point along a polyline based on intersecting a point of a circle with a polyline the centre is always along the poly line but can intersect different segments.

The idea is to walk along the poly line calculating the other points.

I have written a VBA`routine which calcs points along the poly line but I am looking for an easy way to calculate the intersecting points.


Any one done something like this ?

Just an example, not sure that will work what you need
(all of this grabbed from adesk's and another forum)

Option Explicit

Public Function Sel_Poly_Fence(oPoly As AcadLWPolyline) As AcadSelectionSet
Dim vType(0) As Integer
Dim vData(0) As Variant
Dim selCol As AcadSelectionSets
Dim oSelset As AcadSelectionSet
Dim vPts() As Double
Dim mode As Integer
mode = acSelectionSetFence
vType(0) = 0
vData(0) = "CIRCLE"
Set selCol = ThisDrawing.SelectionSets

For Each oSelset In selCol
    If oSelset.Name = "Fence_Sset" Then
        oSelset.Delete
        Exit For
    End If
Next oSelset
Set oSelset = ThisDrawing.SelectionSets.Add("Fence_Sset")
If oPoly.Closed = False Then
vPts = PointArray2dTo3d(oPoly.Coordinates)
Else
vPts = PointArray2dTo3d(Split_Coordinates(oPoly.Coordinates))
End If
oSelset.SelectByPolygon mode, vPts, vType, vData
Set Sel_Poly_Fence = oSelset
End Function
Private Function PointArray2dTo3d(vPts)
Dim vNewPts() As Double
Dim i As Integer
Dim j As Integer

ReDim vNewPts(CInt(1.5 * (UBound(vPts) + 1)) - 1) As Double

j = 0
For i = 0 To UBound(vPts) Step 2
vNewPts(i + j) = vPts(i)
vNewPts(i + j + 1) = vPts(i + 1)
j = j + 1
Next
PointArray2dTo3d = vNewPts
End Function
Public Function Split_Coordinates(oCoords As Variant) As Variant

Dim retArr() As Double
Dim i As Integer
retArr = oCoords
i = UBound(oCoords) + 1
ReDim Preserve retArr(0 To i + 1)
retArr(i) = oCoords(0): retArr(i + 1) = oCoords(1)

Split_Coordinates = retArr
End Function
Sub Test_Fence_Selection()
Dim oPoly As AcadEntity
Dim oCirc As AcadEntity
Dim intArr As Variant
Dim pntList() As Variant
Dim varPnt(0 To 2) As Double
Dim snapPt As Variant
Dim oSelset As AcadSelectionSet
Dim i As Integer
Dim j As Integer

Dim nCirc As AcadCircle
On Error GoTo ErrHand
ThisDrawing.Utility.GetEntity oPoly, snapPt, vbCr & "Select polyline :"

If oPoly.ObjectName = "AcDbPolyline" Then
Set oSelset = Sel_Poly_Fence(oPoly)

Else: MsgBox "This object isn't a polyline!"
Exit Sub
End If

j = -1
For Each oCirc In oSelset
    If IsEmpty(oCirc.IntersectWith(oPoly, acExtendNone)) = True Then
        Exit For

Else
intArr = oCirc.IntersectWith(oPoly, acExtendNone)
For i = 0 To UBound(intArr) - 1 Step 3
varPnt(0) = intArr(i): varPnt(1) = intArr(i + 1): varPnt(2) = intArr(i + 2)
Set nCirc = ThisDrawing.ModelSpace.AddCircle(varPnt, 1.5) 'change diameter by suit
j = j + 1
ReDim Preserve pntList(j)
pntList(j) = varPnt
Next
End If
Next
ErrHand:
MsgBox Err.Description
End Sub

~'J'~

[BIGAL]

Thanks for the help got it to work using intersect need to use an arc rather than a circle stops second answer being generated. others may be interested so here is some code to play with I have left the different options remarked ie line / line, line / arc, line /circle, poly lines etc

there are option on the AcExtend command so a little experimenting is needed.

Sub find_ints()

Dim opoly As AcadEntity
Dim oline1 As AcadEntity
Dim oline2 As AcadEntity
Dim ocirc As AcadEntity
Dim oarc As AcadEntity
Dim arcobj As AcadEntity
Dim retVal As Variant
Dim ptObj As AcadPoint
Dim Pt1(0 To 2) As Double
Dim circObj As AcadCircle
On Error GoTo Something_Wrong
'ThisDrawing.Utility.GetEntity oline1, snapPt, vbCr & "Select line :"
'ThisDrawing.Utility.GetEntity oline2, snapPt, vbCr & "Select line :"
'ThisDrawing.Utility.GetEntity ocirc, snapPt, vbCr & "Select circle :"
'ThisDrawing.Utility.GetEntity oarc, snapPt, vbCr & "Select arc :"
'select last arc drawn automaticaly
ThisDrawing.Utility.GetEntity.last oarc
ThisDrawing.Utility.GetEntity opoly, snapPt, vbCr & "Select polyline :"

'If opoly.ObjectName = "AcDbPolyline" Then
'Coords = opoly.Coordinates
'Else: MsgBox "This object is not a polyline!"
'xit Sub
'End If

'retVal = oline1.IntersectWith(oline2, acExtendBoth)
'retVal = oline1.IntersectWith(opoly, acExtendBoth)
'retVal = ocirc.IntersectWith(opoly, acExtendNone)
retVal = oarc.IntersectWith(opoly, acExtendOtherEntity)
MsgBox retVal(0)
MsgBox retVal(1)

GoTo endprog

Something_Wrong:
MsgBox Err.Description
endprog:

End Sub