[编程交流] 交叉线列表

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

; 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)
)