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

luckyliya · 发表于 2006-3-19 17:24:00

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

雪山飞狐_lzh · 发表于 2006-3-19 21:20:00

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

luckyliya · 发表于 2006-3-19 21:54:00

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

请点击此处下载

请先注册会员后在进行下载

已注册会员，请先登录后下载

文件名称:5rc1y0xwchc.dwg
下载次数:0 文件大小:45.19 KB 售价:2银币 [记录]
下载权限: 不限以上或 Vip会员 [开通Vip] [签到领银币] [免费赚银币]

xinghesnak · 发表于 2006-3-20 16:15:00

我没有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 · 发表于 2006-3-21 21:03:00

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

xinghesnak · 发表于 2006-3-22 08:12:00

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

兰州人 · 发表于 2007-11-6 16:07:00

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