List of intersection lines

[ursan]

Hello

 

I know that ı am able to find a point where two lines are intersected eachother with this command '"object1.IntersectWith(IntersectObjects, ExtendOption)"

 

 

Dim mainLine As AcadLine

Dim line1, line2,line3 As AcadLine

 

i have mainline information. ı want find other lines which are intersected with the main line .

 

for example line1,line2 and line3 are intersected with main line, ı want to find these lines.

 

 

[ronjonp]

Here's a quick one:

(vl-load-com)
(defun c:foo (/ e)
 (and (setq e (car (entsel "\Pick your line: ")))
      (= "LINE" (cdr (assoc 0 (entget e))))
      (sssetfirst
 nil
 (ssget "_F" (list (vlax-curve-getstartpoint e) (vlax-curve-getendpoint e)) '((0 . "line")))
      )
 )
 (princ)
)

[maratovich]

Sample

Public Sub TEST_SelectByIntersection()
 Dim objSS As AcadSelectionSet
 Dim objToCheck As AcadEntity
 Dim varPnt As Variant
 Dim objThatIntersects As AcadEntity
 ThisDrawing.Utility.GetEntity objToCheck, varPnt, "Select an object: "
 Set objSS = SelectByIntersection(objToCheck)
 For Each objThatIntersects In objSS
   objThatIntersects.Highlight True
 Next
 If MsgBox("Object " & CStr(objSS.Count) & _
           " Object." & vbCrLf & "Delete?", _
           vbQuestion + vbYesNo, "TEST_SelectByIntersection") = vbYes Then
   For Each objThatIntersects In objSS
     objThatIntersects.Delete
   Next
 Else
     For Each objThatIntersects In objSS
       objThatIntersects.Highlight False
     Next
 End If
End Sub

Public Function SelectByIntersection(objEnt As AcadEntity) As AcadSelectionSet
 
 On Error Resume Next
 Dim objGen As AcadEntity
 Dim objSelSet As AcadSelectionSet
 Dim objSelCol As AcadSelectionSets
 Dim objArray() As Object
 Dim strName As String
 Dim varMin As Variant
 Dim varMax As Variant
 Dim varIntPnt As Variant
 Dim intcnt As Integer

 objEnt.GetBoundingBox varMin, varMax
 strName = "vbdintersect"
 Set objSelCol = ThisDrawing.SelectionSets
   For Each objSelSet In objSelCol
     If objSelSet.Name = strName Then
       ThisDrawing.SelectionSets.Item(strName).Delete
       Exit For
     End If
   Next
 Set objSelSet = ThisDrawing.SelectionSets.Add(strName)
 objSelSet.Select acSelectionSetCrossing, varMin, varMax
 For Each objGen In objSelSet
   varIntPnt = objEnt.IntersectWith(objGen, acExtendNone)
   
   MsgBox "1 intersection point dedected." & vbCr & _
   "X= " & varIntPnt(0) & ", " & "Y= " & varIntPnt(1) & vbCr, _
   vbInformation, "Intersection Point Dedector"
   
   
   If UBound(varIntPnt) = -1 Then
     ReDim Preserve objArray(intcnt)
     Set objArray(intcnt) = objGen
     intcnt = intcnt + 1
   End If
   varIntPnt = Empty
 Next
 If IsEmpty(objArray) Then
   Set SelectByIntersection = objSelSet
 Else
   objSelSet.RemoveItems objArray
   Set SelectByIntersection = objSelSet
 End If
Exit_Here:
 Exit Function
 MsgBox Err.Description
 Resume Exit_Here
End Function

[ursan]

this code very good working . but I do not understand the autolisp. How to write this code in vb.net / vba or C#.net

[ursan]

Here's a quick one:

(vl-load-com)
(defun c:foo (/ e)
 (and (setq e (car (entsel "\Pick your line: ")))
      (= "LINE" (cdr (assoc 0 (entget e))))
      (sssetfirst
 nil
 (ssget "_F" (list (vlax-curve-getstartpoint e) (vlax-curve-getendpoint e)) '((0 . "line")))
      )
 )
 (princ)
)

 

this code very good working. but I do not understand the autolisp. How to write this code in vb.net / vba or C#.net

[maratovich]

raise your eyes

[ursan]

raise your eyes

 

Why did i say something wrong ?

[maratovich]

Why did i say something wrong ?

I wrote an example for you VBA

But you do not see my example ?

[ursan]

I wrote an example for you VBA

But you do not see my example ?

 

I saw your example. But when the lines have different angles they do not find all the lines.

[ronjonp]

this code very good working. but I do not understand the autolisp. How to write this code in vb.net / vba or C#.net

Sorry .. don't know those languages.

[SLW210]

this code very good working. but I do not understand the autolisp. How to write this code in vb.net / vba or C#.net

 

You have posted this thread in the AutoLISP, Visual LISP & DCL Forum.

 

I have moved your thread to the .NET, ObjectARX & VBA Forum.

[RICVBA]

here's a possible code

 

Option Explicit

Sub ListIntersectingLines()
   Dim linesSset As AcadSelectionSet
   Dim nIntersectingLines As Long
   Dim mainLine As AcadLine, acLine As AcadLine
   
   Set mainLine = GetALine
   
   If Not GetPossiblyCrossingLines(linesSset, mainLine) Then
       MsgBox "no possible intersecting lines with main line"
       Exit Sub
   End If
   
   If FilterActuallyIntersectingLines(linesSset, mainLine) Then
       For Each acLine In linesSset
           nIntersectingLines = nIntersectingLines + 1
           MsgBox "Intersecting line #" & nIntersectingLines & " ID=" & acLine.ObjectID
           acLine.color = acGreen
       Next
   Else
       MsgBox "no intersecting lines with main line"
   End If
End Sub

Function FilterActuallyIntersectingLines(linesSset As AcadSelectionSet, mainLine As AcadLine) As Boolean
   Dim nLines As Long
   Dim acLine As AcadLine
   Dim removeObjectsCounter As Long       
   ReDim removeObjects(0 To linesSset.Count - 1) As AcadEntity

   With mainLine
       For Each acLine In linesSset
           If UBound(.IntersectWith(acLine, acExtendNone)) = -1 Then
               Set removeObjects(removeObjectsCounter) = acLine
               removeObjectsCounter = removeObjectsCounter + 1
           End If
       Next
       If removeObjectsCounter > 0 Then
           ReDim Preserve removeObjects(0 To removeObjectsCounter - 1) As AcadEntity
           linesSset.RemoveItems removeObjects
           FilterActuallyIntersectingLines= linesSset.Count > 0
       End If
   End With
End Function

Function GetALine() As AcadLine
   Dim basePnt As Variant
   
   On Error Resume Next
   Do While GetALine Is Nothing
       ThisDrawing.Utility.GetEntity GetALine, basePnt, "Select a line"
   Loop
End Function

Function GetPossiblyCrossingLines(linesSset As AcadSelectionSet, mainLine As AcadLine) As Boolean
   Dim gpCode(0) As Integer
   Dim dataValue(0) As Variant
   
   gpCode(0) = 0
   dataValue(0) = "LINE"
   On Error Resume Next
   Set linesSset = ThisDrawing.SelectionSets.Add("Lines")
   On Error GoTo 0
   If linesSset Is Nothing Then Set linesSset = ThisDrawing.SelectionSets.Item("Lines")
   
   Dim corner1 As Variant, corner2 As Variant
   mainLine.GetBoundingBox corner1, corner2
   ZoomWindow corner1, corner2
   With linesSset
       .Clear
       .Select acSelectionSetCrossing, corner1, corner2, gpCode, dataValue
       If .Count > 1 Then
           Dim removeObjects(0 To 0) As AcadEntity
           Set removeObjects(0) = mainLine
           .RemoveItems removeObjects
           GetPossiblyCrossingLines= True
       End If
   End With
   ZoomPrevious
End Function

[BIGAL]

Lisp version, note the sneaky x-1 as the pick line is returned as the last object in the selection set, easier than doing a subtle offset and pick pts.

 

; example of intersect with by Alan H Aug 2017
; to use on pline same code but need fence option to use co-ords
; need to add this option see pline co-ords code 

(defun c:ByBIGAL ( / obj obj2 lst ss pt ans)
(setq obj (vlax-ename->vla-object (car (entsel "\nPick object"))))
(if (= "AcDbLine" (vla-get-objectname obj))
(progn
(setq lst (list 
(vlax-safearray->list (vlax-variant-value(vla-get-startpoint obj)))
(vlax-safearray->list (vlax-variant-value(vla-get-endpoint obj)))
))
(setq ans "")
(setq ss (ssget "F" lst (list (cons 0 "Line"))))
(repeat (setq x (- (sslength ss)1))
(setq obj2 (vlax-ename->vla-object (ssname ss (setq x (- x 1)))))
(setq pt (vlax-invoke obj2 'intersectWith obj acExtendThisEntity))
(setq ans (strcat ans "\nX=" (rtos (car pt) 2 3) " " "Y= " (rtos (cadr pt) 2 3) ))
)
)
(alert "Object picked is not a line")
)
(alert ans)c 
(princ)
)

[ursan]

here's a possible code

 

Option Explicit

Sub ListIntersectingLines()
   Dim linesSset As AcadSelectionSet
   Dim nIntersectingLines As Long
   Dim mainLine As AcadLine, acLine As AcadLine
   
   Set mainLine = GetALine
   
   If Not GetPossiblyCrossingLines(linesSset, mainLine) Then
       MsgBox "no possible intersecting lines with main line"
       Exit Sub
   End If
   
   If FilterActuallyIntersectingLines(linesSset, mainLine) Then
       For Each acLine In linesSset
           nIntersectingLines = nIntersectingLines + 1
           MsgBox "Intersecting line #" & nIntersectingLines & " ID=" & acLine.ObjectID
           acLine.color = acGreen
       Next
   Else
       MsgBox "no intersecting lines with main line"
   End If
End Sub

Function FilterActuallyIntersectingLines(linesSset As AcadSelectionSet, mainLine As AcadLine) As Boolean
   Dim nLines As Long
   Dim acLine As AcadLine
   Dim removeObjectsCounter As Long       
   ReDim removeObjects(0 To linesSset.Count - 1) As AcadEntity

   With mainLine
       For Each acLine In linesSset
           If UBound(.IntersectWith(acLine, acExtendNone)) = -1 Then
               Set removeObjects(removeObjectsCounter) = acLine
               removeObjectsCounter = removeObjectsCounter + 1
           End If
       Next
       If removeObjectsCounter > 0 Then
           ReDim Preserve removeObjects(0 To removeObjectsCounter - 1) As AcadEntity
           linesSset.RemoveItems removeObjects
           FilterActuallyIntersectingLines= linesSset.Count > 0
       End If
   End With
End Function

Function GetALine() As AcadLine
   Dim basePnt As Variant
   
   On Error Resume Next
   Do While GetALine Is Nothing
       ThisDrawing.Utility.GetEntity GetALine, basePnt, "Select a line"
   Loop
End Function

Function GetPossiblyCrossingLines(linesSset As AcadSelectionSet, mainLine As AcadLine) As Boolean
   Dim gpCode(0) As Integer
   Dim dataValue(0) As Variant
   
   gpCode(0) = 0
   dataValue(0) = "LINE"
   On Error Resume Next
   Set linesSset = ThisDrawing.SelectionSets.Add("Lines")
   On Error GoTo 0
   If linesSset Is Nothing Then Set linesSset = ThisDrawing.SelectionSets.Item("Lines")
   
   Dim corner1 As Variant, corner2 As Variant
   mainLine.GetBoundingBox corner1, corner2
   ZoomWindow corner1, corner2
   With linesSset
       .Clear
       .Select acSelectionSetCrossing, corner1, corner2, gpCode, dataValue
       If .Count > 1 Then
           Dim removeObjects(0 To 0) As AcadEntity
           Set removeObjects(0) = mainLine
           .RemoveItems removeObjects
           GetPossiblyCrossingLines= True
       End If
   End With
   ZoomPrevious
End Function

 

thank you for reply. when i change custom corner1 and corner2 perfect work program.

But it does not work when two lines are back to back. I added sample pictures. line1 and line2 are two interlaced lines. After running the program line1 color again white. what command line1 will detect?

[RICVBA]

it 's because overlapping lines won't have

IntersectWith() 

method catch any intersection points

 

you could handle this exception by trying and see if any line parallel to the main one is overlapping (hence intersecting) also in many ways

 

here is one of them (only showing changed subs/function):

 

Function FilterActuallyIntersectingLines(linesSset As AcadSelectionSet, mainLine As AcadLine) As Boolean
   Dim acLine As AcadLine
   Dim removeObjectsCounter As Long
   ReDim removeObjects(0 To linesSset.Count - 1) As AcadEntity

   With mainLine
       For Each acLine In linesSset
           If Not DoesItIntersect(mainLine, acLine) Then '<--| have a specialized function detect "true" intersection
               Set removeObjects(removeObjectsCounter) = acLine
               removeObjectsCounter = removeObjectsCounter + 1
           End If
       Next
       If removeObjectsCounter > 0 Then
           ReDim Preserve removeObjects(0 To removeObjectsCounter - 1) As AcadEntity
           linesSset.RemoveItems removeObjects
       End If
   End With
   FilterActuallyIntersectingLines = linesSset.Count > 0 '<--| note I changed this line position
End Function

Function DoesItIntersect(mainLine As AcadLine, currentLine As AcadLine) As Boolean
   Const PI = 3.14159265358979
   If UBound(mainLine.IntersectWith(currentLine, acExtendNone)) = -1 Then
       If Round(mainLine.Angle - PI * (mainLine.Angle \ PI) - (currentLine.Angle - PI * (currentLine.Angle \ PI)), 4) = 0 Then ' if the passed line is parallel to the main one
           Dim endPoint As Variant
           endPoint = currentLine.endPoint
           endPoint(0) = endPoint(0) + 0.01 ' spot a point a little shifted from the current line end point
           With ThisDrawing.ModelSpace.AddLine(currentLine.StartPoint, endPoint) ' draw a line with current line start point and the "shifted" end point
               DoesItIntersect = UBound(.IntersectWith(mainLine, acExtendNone)) >= 0 ' if it intersects the main line then the current line overlaps it
               .Delete
           End With
       End If
   Else
       DoesItIntersect = True
   End If
End Function