VBA能不能实现遍历指定图层内所有实体

spano

如题，能不能用类似如下格式遍历图层内所有实体？    Dim k, l As Integer
    Dim temp_entity As AcadEntity
    Dim Temp_Layer As AcadLayer
    k = 0
    l = 0
    For Each Temp_Layer In ThisDrawing.Layers
        Layer_Name(k) = Temp_Layer.Name
        For Each temp_entity In Temp_Layer  ‘此处报错
            l = l + 1
        Next
        MsgBox("该图层有"&Cstr(l)&“个实体”)
   Next

zzyong00

1. Private Sub SelectLots(ByVal Ssetname As String, ByVal strLayerName As String)
   
2.    
   
3.     Dim sSetObj As AcadSelectionSet, flag As Boolean
   
4.     If ThisDrawing.GetVariable("cmdactive") Then ThisDrawing.SendCommand "(command)"
   
5.    
   
6.     For Each sSetObj In ThisDrawing.SelectionSets
   
7.         
   
8.         If sSetObj.Name = Ssetname Then
   
9.             flag = True
   
10.             Exit For
    
11.         End If
    
12.         
    
13.     Next
    
14.    
    
15.     If flag Then sSetObj.Delete                                                 '创建集合，如集存在，则删除，新建
    
16.     Set sSetObj = ThisDrawing.SelectionSets.Add(Ssetname)
    
17.    
    
18.     Dim gpCode(0)    As Integer
    
19.    
    
20.     Dim dataValue(0) As Variant
    
21.    
    
22. 
    
23.     gpCode(0) = 8
    
24.     dataValue(0) = strLayerName                                                 ' 图层名
    
25.    
    
26.     Dim groupCode As Variant, dataCode As Variant
    
27.    
    
28.     groupCode = gpCode
    
29.     dataCode = dataValue
    
30.    
    
31.     sSetObj.Select acSelectionSetAll, , , groupCode, dataCode
    
32. End Sub
    
33. 
    
34. Public Sub test()
    
35.     Dim objSset As AcadSelectionSet
    
36.     SelectLots "z1111", "0" '选0层的所有对象
    
37.     Set objSset = ThisDrawing.SelectionSets("z1111")
    
38.     If objSset.Count = 0 Then Exit Sub
    
39.     Dim objEnt As AcadEntity
    
40.     For Each objEnt In objSset
    
41.         Debug.Print objEnt.ObjectName
    
42.     Next objEnt
    
43. 
    
44. End Sub
    

Private Sub SelectLots(ByVal Ssetname As String, ByVal strLayerName As String)<br />     <br />     Dim sSetObj As AcadSelectionSet, flag As Boolean<br />     If ThisDrawing.GetVariable("cmdactive") Then ThisDrawing.SendCommand "(command)"<br />     <br />     For Each sSetObj In ThisDrawing.SelectionSets<br />         <br />         If sSetObj.Name = Ssetname Then<br />             flag = True<br />             Exit For<br />         End If<br />         <br />     Next<br />     <br />     If flag Then sSetObj.Delete                                                 '创建集合，如集存在，则删除，新建<br />     Set sSetObj = ThisDrawing.SelectionSets.Add(Ssetname)<br />     <br />     Dim gpCode(0)    As Integer<br />     <br />     Dim dataValue(0) As Variant<br />     <br /> <br />     gpCode(0) = 8<br />     dataValue(0) = strLayerName                                                 ' 图层名<br />     <br />     Dim groupCode As Variant, dataCode As Variant<br />     <br />     groupCode = gpCode<br />     dataCode = dataValue<br />     <br />     sSetObj.Select acSelectionSetAll, , , groupCode, dataCode<br /> End Sub<br /> <br /> Public Sub test()<br />     Dim objSset As AcadSelectionSet<br />     SelectLots "z1111", "0" '选0层的所有对象<br />     Set objSset = ThisDrawing.SelectionSets("z1111")<br />     If objSset.Count = 0 Then Exit Sub<br />     Dim objEnt As AcadEntity<br />     For Each objEnt In objSset<br />         Debug.Print objEnt.ObjectName<br />     Next objEnt<br /> <br /> End Sub<br />

zzyong00

按图层选择，创建选择集，遍历。。。

mikewolf2k

对象不是属于图层的，是属于document的。要实现这个效果可以遍历对象，然后看对象的图层是不是满足你需要的。

spano

mikewolf2k 发表于 2018-3-2 13:16
对象不是属于图层的，是属于document的。要实现这个效果可以遍历对象，然后看对象的图层是不是满足你需要的 ...

哦，谢谢了，这对对象很多的图会不会拖慢速度？

wuyunpeng888

选择集处理不了块内图形对象，要处理全部，可以从块集合来遍历,或从模型空间开始，遇到参照再递归处理对应的块