IntersectWith motod problem VBA

[4gokay372489]

I got to the point of intersection of two polylines. The process will be repeated many times. However, according to the VBA codes trying different UCS coordinates. Codes in area 1 is working correctly. Working in the wrong area 2.

Similarly, there is also the problem trim. You can see the link below.

http://forums.augi.com/showthread.ph...80#post1212980

• /////////
  Sub IPNT()
  Dim objSS As AcadSelectionSet
  Dim objSS2 As AcadSelectionSet
  Dim Poly1 As AcadLWPolyline
  Dim Poly2 As AcadLWPolyline
  On Error Resume Next
  ThisDrawing.SelectionSets("TempSSet1").Delete
  On Error Resume Next
  Set objSS = ThisDrawing.SelectionSets.Add("TempSSet1")
  If Err Then Exit Sub
  MsgBox "Select Poly 1"
  objSS.SelectOnScreen
  For Each Poly1 In objSS
  Exit For: Next
  On Error Resume Next
  ThisDrawing.SelectionSets("TempSSet2").Delete
  On Error Resume Next
  Set objSS2 = ThisDrawing.SelectionSets.Add("TempSSet2")
  If Err Then Exit Sub
  MsgBox "Select Poly 2"
  objSS2.SelectOnScreen
  For Each Poly2 In objSS2
  Exit For: Next
  pts = Poly1.IntersectWith(Poly2, acExtendNone)
  MsgBox "X= " & pts(0) & vbCr & "Y= " & pts(1), vbInformation, "Intersection Point"
  End Sub
  /////////

Thanks for help.

[arshiel88]

After testing the vba code, I confirmed that there is an issue in the IntersectWith statement in Area 2. I don't know how and why this is happening but IntersectWith detects 2 intersections in Area 2. We can discard the other intersection (via Redim - see code) if you will use the code on polylines with only one real intersection, hoping/assuming that vba finds the real intersection first.

here's the modified code.

Sub IPNT()

Dim Poly1 As AcadLWPolyline
Dim Poly2 As AcadLWPolyline
Dim pts As Variant


On Error Resume Next

ThisDrawing.Utility.GetEntity Poly1, pickPt, "Pick Poly1:"
If Err Then Exit Sub
ThisDrawing.Utility.GetEntity Poly2, pickPt, "Pick Poly2:"
If Err Then Exit Sub

pts = Poly1.IntersectWith(Poly2, acExtendNone)
MsgBox "Found " & (UBound(pts) + 1) / 3 & " intersection/s."

'-----------------------------------use this to use only the first intersection
ReDim Preserve pts(2)
ThisDrawing.ModelSpace.AddPoint pts
'-----------------------------------use this to use only the first intersection



'-----------------------------------------use this to display all intersections
'Dim ptCoord(0 To 2) As Double
'For i = 0 To UBound(pts) Step 3
    'ptCoord(0) = pts(i): ptCoord(1) = pts(i + 1): ptCoord(2) = pts(i + 2)
    'Debug.Print ptCoord(0); ptCoord(1); ptCoord(2)
    'ThisDrawing.ModelSpace.AddPoint ptCoord
'Next
'-----------------------------------------use this to display all intersections

End Sub

...and please use [code] tags for easy code reading. Good luck.