求出某一图元和图上其他图元的所有交点,并新建一个“交点图层”，在所有交点处画一

超然A

求出某一图元和图上其他图元的所有交点,并新建一个“交点图层”，在所有交点处画一个半径为5的圆[br]

2. Option Explicit
3. '求出某一图元和图上其他图元的所有交点,并新建一个“交点图层”，在所有交点处画一个半径为5的圆
4. Public Sub aaa()
5. On Error Resume Next
6. Dim ent1 As AcadEntity
7. Dim ent2 As AcadEntity
8. Dim sset As AcadSelectionSet
9. ThisDrawing.Utility.GetEntity ent1, "", "选择要求交点的图元："
10. Dim ptmin As Variant
11. Dim ptmax As Variant
12. 'ptmin，ptmax分别是图元ent1的最小外接矩形的左下角坐标和右上角坐标
13. ent1.GetBoundingBox ptmin, ptmax
14. Dim lay01 As AcadLayer
15. Dim lay11 As AcadLayer
16. Dim findlay As Integer
17. findlay = 0 '寻找图层的结果的变量，0没有找到，1找到
18. For Each lay01 In ThisDrawing.Layers '在所有的图层中进行循环
19.   If lay01.Name = "交点图层" Then '如果找到图层名
20.     findlay = 1 '把变量改为1标志着图层已经找到
21.        If Not lay01.LayerOn Then lay01.LayerOn = True '打开
22.        ThisDrawing.ActiveLayer = lay01 '把当前图层设为已经存在的图层
23.     End If
24.   Exit For '结束寻找
25. Next lay01
26. If findlay = 0 Then '没有找到图层
27.   Set lay11 = ThisDrawing.Layers.Add("交点图层") '增加一个名为“交点图层”的图层
28.   lay11.color = 1 '图层设置为红色
29.   ThisDrawing.ActiveLayer = lay11 '将当前图层设置为交点图层
30. End If
31. '安全创建选择集
32. If Not IsNull(ThisDrawing.SelectionSets.Item("exa")) Then
33. Set sset = ThisDrawing.SelectionSets.Item("exa")
34. sset.Delete
35. End If
36. Set sset = ThisDrawing.SelectionSets.Add("exa")
37. '构造以ptmin，ptmax为界的交叉选择集
38. sset.Select acSelectionSetCrossing, ptmin, ptmax
39. '从选择集中删除ent1图元
40. Dim objArray(0 To 0) As AcadEntity
41.     Set objArray(0) = ent1
42.     sset.RemoveItems objArray
43. '循环选择集
44. For Each ent2 In sset
45. Call Draw_Circle(ent1, ent2)
46. Next ent2
47. End Sub
48. '子函数
49. '作用是：求两个图元的交点，并在交点处画一个半径为5的圆
50. Private Function Draw_Circle(ByVal ent11 As AcadEntity, ByVal ent22 As AcadEntity) As AcadEntity
51. Dim pts As Variant
52. Dim cir As AcadCircle
53. Dim pt(0 To 2) As Double
54. pts = ent11.IntersectWith(ent22, acExtendNone)
55. Dim I As Integer
56. Dim str As String
57. If VarType(pts) <> vbEmpty Then
58. For I = LBound(pts) To UBound(pts) Step 3
59. pt(0) = pts(I): pt(1) = pts(I + 1): pt(2) = pts(I + 2)
60. Set cir = ThisDrawing.ModelSpace.AddCircle(pt, 5)
61. Next I
62. End If
63. End Function

Option Explicit '求出某一图元和图上其他图元的所有交点,并新建一个“交点图层”，在所有交点处画一个半径为5的圆 Public Sub aaa() On Error Resume Next Dim ent1 As AcadEntity Dim ent2 As AcadEntity Dim sset As AcadSelectionSet ThisDrawing.Utility.GetEntity ent1, "", "选择要求交点的图元：" Dim ptmin As Variant Dim ptmax As Variant 'ptmin，ptmax分别是图元ent1的最小外接矩形的左下角坐标和右上角坐标 ent1.GetBoundingBox ptmin, ptmax Dim lay01 As AcadLayer Dim lay11 As AcadLayer Dim findlay As Integer findlay = 0 '寻找图层的结果的变量，0没有找到，1找到 For Each lay01 In ThisDrawing.Layers '在所有的图层中进行循环   If lay01.Name = "交点图层" Then '如果找到图层名     findlay = 1 '把变量改为1标志着图层已经找到        If Not lay01.LayerOn Then lay01.LayerOn = True '打开        ThisDrawing.ActiveLayer = lay01 '把当前图层设为已经存在的图层     End If   Exit For '结束寻找 Next lay01 If findlay = 0 Then '没有找到图层   Set lay11 = ThisDrawing.Layers.Add("交点图层") '增加一个名为“交点图层”的图层   lay11.color = 1 '图层设置为红色   ThisDrawing.ActiveLayer = lay11 '将当前图层设置为交点图层 End If '安全创建选择集 If Not IsNull(ThisDrawing.SelectionSets.Item("exa")) Then Set sset = ThisDrawing.SelectionSets.Item("exa") sset.Delete End If Set sset = ThisDrawing.SelectionSets.Add("exa") '构造以ptmin，ptmax为界的交叉选择集 sset.Select acSelectionSetCrossing, ptmin, ptmax '从选择集中删除ent1图元 Dim objArray(0 To 0) As AcadEntity     Set objArray(0) = ent1     sset.RemoveItems objArray '循环选择集 For Each ent2 In sset Call Draw_Circle(ent1, ent2) Next ent2 End Sub '子函数 '作用是：求两个图元的交点，并在交点处画一个半径为5的圆 Private Function Draw_Circle(ByVal ent11 As AcadEntity, ByVal ent22 As AcadEntity) As AcadEntity Dim pts As Variant Dim cir As AcadCircle Dim pt(0 To 2) As Double pts = ent11.IntersectWith(ent22, acExtendNone) Dim I As Integer Dim str As String If VarType(pts) <> vbEmpty Then For I = LBound(pts) To UBound(pts) Step 3 pt(0) = pts(I): pt(1) = pts(I + 1): pt(2) = pts(I + 2) Set cir = ThisDrawing.ModelSpace.AddCircle(pt, 5) Next I End If End Function