求出某一图元和图上其他图元的所有交点,并新建一个“交点图层”，在所有交点处画一
求出某一图元和图上其他图元的所有交点,并新建一个“交点图层”，在所有交点处画一个半径为5的圆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
页:
[1]