[编程交流] 交叉线列表

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

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