您已经在AutoLISP、Visual LISP和DCL论坛上发布了此线程。
我已将您的线程移动到。NET、ObjectARX和VBA论坛。 这是一个可能的代码
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 Lisp版本中，请注意，当拾取线作为选择集中的最后一个对象返回时，会出现鬼鬼祟祟的x-1，这比执行微妙的偏移和拾取点更容易。
; 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)
)
谢谢你的回复。当我更改custom corner1和corner2完美工作程序时。
但当两条线背靠背时，它不起作用。我添加了示例图片。line1和line2是两条交错的线。运行程序后，line1颜色再次为白色。命令行1将检测什么？
这是因为重叠的线条不会
方法捕捉任何交点
您可以通过尝试查看与主线段平行的任何线段是否也在许多方面重叠（因此相交）来处理此异常
以下是其中之一（仅显示更改的子/函数）：
函数FilterActuallyIntersectingLines（linesSset为AcadSelectionSet，mainLine为AcadLine）作为布尔Dim acLine作为AcadLine Dim removeObjects输入只要ReDim removeObjects（0到linesSset。Count-1）作为linesSset中每个acLine的mainLine的身份如果没有doestintersect（mainLine，acLine），则“0”，然后ReDim Preserve removeObjects（0以删除ObjectsCenter-1）作为身份线集。如果以FilterActuallyIntersectingLines=LinesSet结尾，则RemoveItems removeObjects结束。计数>0’
页:
1
[2]