求助高手帮忙修改下程序
我想遍历图层"ab1"中的图块及图层"abcd"的闭合多段线,如果图块的坐标在闭合多段线的区域外,则把区域外的图块删除,如在闭合的区域内,则保留。我想把图块的坐标点画圆，面域，把闭合多段线也进行面域，并求交，如有相交，则保留，没相交则删除，
可是我这个程序有问题，下面也不知道怎么编了，请高手帮帮忙，帮我修改一下。
Sub Example_Select() '选择某图层的图块与多段线区域比较
Dim ssetObj As AcadSelectionSet
On Error Resume Next
Set ssetObj = ThisDrawing.SelectionSets.Add("SSET")
If Err0 Then
Set ssetObj = ThisDrawing.SelectionSets.Item("SSET")
ssetObj.Clear
End If
Dim mode As Integer
Dim object As AcadEntity
mode = acSelectionSetAll
Dim gpCode(1) As Integer
Dim dataValue(1) As Variant
gpCode(0) = 0
dataValue(0) = "insert"
gpCode(1) = 8
dataValue(1) = "ab1"
Dim groupCode As Variant, dataCode As Variant
groupCode = gpCode
dataCode = dataValue
ssetObj.Select mode, , , groupCode, dataCode
'提示有几个对象加入选择集
MsgBox "图中有" & ssetObj.Count & "个图元已加入到选择集SSET中。"
'遍历程序
For i = 0 To ssetObj.Count - 1
Set object = ssetObj.Item(i)
Next i
'定义变量为变体型
Dim xy As Variant
'遍历选择集的对象
For Each ent In ssetObj
'求出块对象的坐标
xy = ent.InsertionPoint
'以下为绘制圆程序
Dim cobj(0 To 0) As AcadCircle
Set cobj(0) = ThisDrawing.ModelSpace.AddCircle(xy, 50)
cobj(0).Layer = "ab1"
'对圆进行面域
Dim regionobj As Variant
regionobj = ThisDrawing.ModelSpace.AddRegion(cobj)
cobj(0).Erase
Next
'MsgBox "坐标是：" & xy(0)
'''''''''''''
'以上部分为图块坐标提取程序
'''''''''''''''''''''''
'以下部分为多段线提取并面域
Dim ssetObj1 As AcadSelectionSet
Set ssetObj1 = ThisDrawing.SelectionSets.Add("SSET1")
If Err0 Then
Set ssetObj1 = ThisDrawing.SelectionSets.Item("SSET1")
ssetObj1.Clear
End If
Dim mode1 As Integer
Dim object1(0 To 0) As AcadEntity
mode1 = acSelectionSetAll
Dim gpCode1(1) As Integer
Dim dataValue1(1) As Variant
gpCode1(0) = 0
dataValue1(0) = "LWPOLYLINE"
gpCode1(1) = 8
dataValue1(1) = "abcd"
Dim groupCode1 As Variant, dataCode1 As Variant
groupCode1 = gpCode1
dataCode1 = dataValue1
ssetObj1.Select mode1, , , groupCode1, dataCode1
'显示有几个图元加入选择集内
MsgBox "图中有" & ssetObj1.Count & "个图元已加入到选择集SSET中。"
For i1 = 0 To ssetObj1.Count - 1
Set object1(0) = ssetObj1.Item(i1)
If Not Err Then
Dim regionobj1 As Variant
regionobj1 = ThisDrawing.ModelSpace.AddRegion(object1)
End If
Next i1
Dim roundroomobj As AcadRegion
Dim pillarobj As AcadRegion
'If regionobj(0).Area > regionobj1(0).Area Then
Set roundroomobj = regionobj1(0)
Set pillarobj = regionobj(0)
'Else
'Set pillarobj = regionobj1(0)
'Set roundroomobj = regionobj(0)
'End If
roundroomobj.Color = acRed
pillarobj.Color = acCyan
roundroomobj.Boolean acIntersection, pillarobj
End Sub
我的想法，通过过滤，选出abcd图层的多段线，然后创建新选集，通过选集SelectByPolygon，把选到的块添加到选集。删出选集中没有的块
还是搞不来,请高手帮帮忙吧 提供图纸测试
改变下方法吧!判断块的插入点是否在多段线内(搜搜,有代码的),否就删了,
这个是图纸，请高手们帮忙 高手们,帮帮们吧,帮我编一下吧,我实在是编不出来了
Sub test()
On Error Resume Next
'多段线选集
Dim plsltset As AcadSelectionSet
ThisDrawing.SelectionSets.Add "plsltset"
Set plsltset = ThisDrawing.SelectionSets.Item("plsltset")
'初始化
plsltset.Clear'过滤出abcd图层的多段线
Dim ft(0 To 1) As Integer
Dim fd(0 To 1) As Variant
ft(0) = 0
fd(0) = "LWPOLYLINE"
ft(1) = 8
fd(1) = "abcd"
plsltset.Select acSelectionSetAll, , , ft, fd
'块选集
Dim blksltset As AcadSelectionSet
ThisDrawing.SelectionSets.Add "blksltset"
Set blksltset = ThisDrawing.SelectionSets.Item("blksltset")
'初始化
blksltset.Clear
'多段线
Dim plobj As AcadLWPolyline
'块过滤
ft(0) = 0
fd(0) = "INSERT"
ft(1) = 8
fd(1) = "AB1"
'遍历多段线选集选择块
For Each plobj In plsltset
'多段线顶点
Dim plpts As Variant
plpts = plobj.Coordinates
'二维点转换为三维点
ReDim sspts(0 To ((UBound(plpts) + 1) * 3 / 2 - 1)) As Double
Dim j As Integer
j = 0
For i = 0 To UBound(plpts) - 1 Step 2
sspts(j) = plpts(i)
sspts(j + 1) = plpts(i + 1)
sspts(j + 2) = 0
j = j + 3
Next
'选择块
blksltset.SelectByPolygon acSelectionSetCrossingPolygon, sspts, ft, fd
Next
'选择所有AB1图层上的块
Dim allblksltset As AcadSelectionSet
ThisDrawing.SelectionSets.Add "allblksltset"
Set allblksltset = ThisDrawing.SelectionSets.Item("allblksltset")
allblksltset.Select acSelectionSetAll, , , ft, fd
ReDim objs(0 To blksltset.Count - 1) As Object
'多边形内的所有对象
For i = 0 To blksltset.Count - 1
Set objs(i) = blksltset(i)
Next
'剔除多边形内的对象
allblksltset.RemoveItems (objs)
'删除其余对象
allblksltset.Erase
'收工
End Sub
楼上的写的非常不错
谢谢楼上的兄弟了,我试用下
页:
[1]