如何寻找图形中所有直线的交点并把它们变成红色或与其它图元加以区别

luckyliya

各位大侠帮帮忙,请问如何寻找图形中所有直线的交点并把它们变成红色或与其它图元加以区别

雪山飞狐_lzh

找到交点就画个红色的点：），有什么问题么？

luckyliya

可我实在很菜呀,具体代码能帮发一下吗,我的图形是这样的,直线与直线的交点都要找到

xinghesnak

我没有2004版本,所以下面的这个大概做了个样子...具体还是得你自己调试

Dim Circle1 As AcadCircle
For i = 0 To ThisDrawing.ModelSpace.Count
    On Error Resume Next
    Set object = ThisDrawing.ModelSpace.Item(i)
    If Not Err Then
        For j = i To ThisDrawing.ModelSpace.Count
            point = object.IntersectWith(ThisDrawing.ModelSpace.Item(j), acExtendNone)
            If point <> "" Then
'                你要做的处理,变红或者别的
'                Set Circle1 = ThisDrawing.ModelSpace.AddCircle(point, 200)
'                Circle1.Color = acRed
            End If
        Next
    End If
Next
ThisDrawing.Application.Update

chtd

最好定义一下选择集，不然后生成的圆也会计算。

xinghesnak

chtd说得有道理..应该定义一下选择集

兰州人

Sub Example_IntersectWith()
    ' This example creates a line and circle and finds the points at
    ' which they intersect.
    Dim Object As AcadEntity, Object1 As AcadEntity
    Dim ii As Integer
    Dim ppt As Variant
    For ii = 0 To ThisDrawing.ModelSpace.Count - 1
      On Error Resume Next
      Set Object = ThisDrawing.ModelSpace.Item(ii)
      If ii = ThisDrawing.ModelSpace.Count - 1 Then
        Set Object1 = ThisDrawing.ModelSpace.Item(0)
      Else
        Set Object1 = ThisDrawing.ModelSpace.Item(ii + 1)
      End If
      'Debug.Print Object.Handle, Object1.Handle
      ppt = Object1.IntersectWith(Object, acExtendBoth)
      Debug.Print ii, ppt(0), ppt(1), ppt(2)
   
   
    Next ii
End Sub

chtd

对于不在一个平面上的两条线，IntersectWith不好使，还需要将两条线投影到一个平面上。

gdzhou

我有多段线的

没有直线检查的。。。

junhua1123

楼上这个检查线相交做得不到位,用的可能是IntersectWith方法,所以对不同标高的多线段检查不出.