求助高手帮忙修改下程序

xgngg

我想遍历图层"ab1"中的图块及图层"abcd"的闭合多段线,如果图块的坐标在闭合多段线的区域外,则把区域外的图块删除,如在闭合的区域内,则保留。

我想把图块的坐标点画圆，面域，把闭合多段线也进行面域，并求交，如有相交，则保留，没相交则删除，

可是我这个程序有问题，下面也不知道怎么编了，请高手帮帮忙，帮我修改一下。

Sub Example_Select()       '选择某图层的图块与多段线区域比较
Dim ssetObj As AcadSelectionSet
On Error Resume Next
Set ssetObj = ThisDrawing.SelectionSets.Add("SSET")
If Err <> 0 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 Err <> 0 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

sailorcwx

我的想法，通过过滤，选出abcd图层的多段线，然后创建新选集，通过选集SelectByPolygon，把选到的块添加到选集。删出选集中没有的块

xgngg

还是搞不来,请高手帮帮忙吧

sailorcwx

提供图纸测试

fjfhgdwfn

改变下方法吧!判断块的插入点是否在多段线内(搜搜,有代码的),否就删了,

xgngg

这个是图纸，请高手们帮忙

xgngg

高手们,帮帮们吧,帮我编一下吧,我实在是编不出来了

sailorcwx

2. Sub test()
3. On Error Resume Next
4. '多段线选集
5. Dim plsltset As AcadSelectionSet
6. ThisDrawing.SelectionSets.Add "plsltset"
7. Set plsltset = ThisDrawing.SelectionSets.Item("plsltset")
8. '初始化
9. plsltset.Clear
11. '过滤出abcd图层的多段线
12. Dim ft(0 To 1) As Integer
13. Dim fd(0 To 1) As Variant
14. ft(0) = 0
15. fd(0) = "LWPOLYLINE"
16. ft(1) = 8
17. fd(1) = "abcd"
18. plsltset.Select acSelectionSetAll, , , ft, fd
19. '块选集
20. Dim blksltset As AcadSelectionSet
21. ThisDrawing.SelectionSets.Add "blksltset"
22. Set blksltset = ThisDrawing.SelectionSets.Item("blksltset")
23. '初始化
24. blksltset.Clear
25. '多段线
26. Dim plobj As AcadLWPolyline
27. '块过滤
28. ft(0) = 0
29. fd(0) = "INSERT"
30. ft(1) = 8
31. fd(1) = "AB1"
32. '遍历多段线选集选择块
33. For Each plobj In plsltset
34. '多段线顶点
35. Dim plpts As Variant
36. plpts = plobj.Coordinates
37. '二维点转换为三维点
38. ReDim sspts(0 To ((UBound(plpts) + 1) * 3 / 2 - 1)) As Double
39. Dim j As Integer
40. j = 0
41. For i = 0 To UBound(plpts) - 1 Step 2
42. sspts(j) = plpts(i)
43. sspts(j + 1) = plpts(i + 1)
44. sspts(j + 2) = 0
45. j = j + 3
46. Next
47. '选择块
48. blksltset.SelectByPolygon acSelectionSetCrossingPolygon, sspts, ft, fd
49. Next
50. '选择所有AB1图层上的块
51. Dim allblksltset As AcadSelectionSet
52. ThisDrawing.SelectionSets.Add "allblksltset"
53. Set allblksltset = ThisDrawing.SelectionSets.Item("allblksltset")
54. allblksltset.Select acSelectionSetAll, , , ft, fd
55. ReDim objs(0 To blksltset.Count - 1) As Object
56. '多边形内的所有对象
57. For i = 0 To blksltset.Count - 1
58. Set objs(i) = blksltset(i)
59. Next
60. '剔除多边形内的对象
61. allblksltset.RemoveItems (objs)
62. '删除其余对象
63. allblksltset.Erase
64. '收工
65. End Sub

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

fjfhgdwfn

楼上的写的非常不错

xgngg

谢谢楼上的兄弟了,我试用下