[VBA程序]：层的删除问题

indal

层上有块，而块又被其它层用，能不能通过改块的属性来删该层呢？又是怎样改属性的呢？

XDSoft

最初由 indal 发布
[B]层上有块，而块又被其它层用，能不能通过改块的属性来删该层呢？又是怎样改属性的呢？ [/B]

一个层只有在没有被其他对象引用的前提下，才可以删除掉。

即使一个层上没有任何实体了，但是如果其他层上的比如块，XREF等内的子实体引用了该层，也不能删除，删除会引起ACAD崩溃。

所以，第一步要做的是判断是否有对象引用该层，确保没有后，再有层对象的删除方法，安全删除掉。

可以通过修改其他层块引用该层的子实体修改层属性到其他层的方法。

indal

怎样判断是否有对象引用该层？（VBA中是怎样实现的？）
而修改块中对象的层属性又是怎样修改的？

XDSoft

最初由 indal 发布
[B]怎样判断是否有对象引用该层？（VBA中是怎样实现的？）
而修改块中对象的层属性又是怎样修改的？ [/B]

VBA中可以使用PURGEALL方法删除所有的没有使用的匿名块和层。

2. 
   
3. [FONT=courier new]
   
4. Removes unused named references such as unused blocks or layers from the document.
   
5. 
   
6. See Also | Example
   
7. 
   
8. Signature
   
9. 
   
10. object.PurgeAll
    
11. 
    
12. Object
    
13. 
    
14. Document
    
15. The object or objects this method applies to.
    
16. 
    
17. Remarks
    
18. 
    
19. This method is the equivalent of enteringPURGE on the command line, selecting the All option and choosing Yes to the Purge Everything? prompt.
    
20. 
    
21. Deleted objects remain in the document until they are purged using this method.
    
22. [/FONT]

<br /> [FONT=courier new]<br /> Removes unused named references such as unused blocks or layers from the document.<br /> <br /> See Also | Example<br /> <br /> Signature <br /> <br /> object.PurgeAll <br /> <br /> Object<br /> <br /> Document<br /> The object or objects this method applies to. <br /> <br /> Remarks <br /> <br /> This method is the equivalent of enteringPURGE on the command line, selecting the All option and choosing Yes to the Purge Everything? prompt. <br /> <br /> Deleted objects remain in the document until they are purged using this method. <br /> [/FONT]

例子：

2. 
   
3. [FONT=courier new]
   
4. Sub Example_PurgeAll()
   
5.     ' This example removes all unused named references from the database
   
6.    
   
7.     ThisDrawing.PurgeAll
   
8.    
   
9. End Sub
   
10. [/FONT]

<br /> [FONT=courier new]<br /> Sub Example_PurgeAll()<br />     ' This example removes all unused named references from the database<br />     <br />     ThisDrawing.PurgeAll<br />     <br /> End Sub<br /> [/FONT]

XDSoft

你可以遍历块表，查询块里面的每个对象的层名是否等于你需要删除的层名，如果等，用修改属性方法，修改对象的层名到其他层。

2. 
   
3. [FONT=courier new]
   
4. Sub del_layer()
   
5. Dim a_app As AcadApplication
   
6. Dim a_blks As AcadBlocks
   
7. Dim obj As Object
   
8. On Error Resume Next
   
9. 
   
10. Set a_app = GetObject(, "AutoCAD.Application.15")
    
11. Set a_blks = a_app.ActiveDocument.Blocks //获得块表
    
12. 
    
13. For Each obj In a_blks  //遍历循环
    
14.      If (obj.Layer=="YOUR LAYER NAME" Then
    
15.           .............//加入修改对象层名代码
    
16.      End If
    
17. Next obj
    
18. End Sub
    
19. [/FONT]

<br /> [FONT=courier new]<br /> Sub del_layer()<br /> Dim a_app As AcadApplication<br /> Dim a_blks As AcadBlocks<br /> Dim obj As Object<br /> On Error Resume Next<br /> <br /> Set a_app = GetObject(, "AutoCAD.Application.15")<br /> Set a_blks = a_app.ActiveDocument.Blocks //获得块表<br /> <br /> For Each obj In a_blks  //遍历循环<br />      If (obj.Layer=="YOUR LAYER NAME" Then<br />           .............//加入修改对象层名代码<br />      End If<br /> Next obj<br /> End Sub<br /> [/FONT]

我不用VBA，所以只能努力给你找资料，借用ARX和LISP的知识做回复，你可以参考下，方法应该是相通的。

如果你解决了，希望把代码贴到论坛来，和大家共享。

欢迎你常来”晓东CAD空间“。

indal

学CAD二次开发的人不来晓东CAD空间，那可以说是一种损失，很大的损失！
我也不太懂VBA，我只是用VC里的acad.tlb，他们好象也基本一样，我参考的是VBA。
我会尽快把代码贴出来的

indal

1. 
   
2. [FONT=courier new]
   
3. CString oldlayername;
   
4.         CString newlayername;
   
5.         oldlayername="oldlayer";
   
6.         newlayername="newlayer";
   
7.         for(int i=0;i< m_acadblocks.GetCount();i++)
   
8.         {
   
9.                 m_acadblock.AttachDispatch(m_acadblocks.Item(COleVariant((short)i)),true);
   
10.                 for(int j=0;j< m_acadblock.GetCount();j++)
    
11.                 {       
    
12.                         m_acadentity=m_acadblock.Item(COleVariant((short)j));
    
13.                         if(!strcmp(oldlayername,m_acadentity.GetLayer()))
    
14.                                 m_acadentity.SetLayer(newlayername);
    
15. 
    
16.                 }
    
17.         }[/FONT]

复制代码

indal

多谢XD帮助修改
IAcadLayer.delete()可把oldlayer层删除！

efan2000

检查层引用的函数如下：

2. 
   
3.   [FONT=courier new]
   
4. '检查层引用是否存在
   
5. '输入：Name-层名
   
6. 输出：LayerRefExist，TRUE表示层引用存在
   
7. Public Function LayerRefExist(ByVal Name As String) As Boolean
   
8.     Dim EntObj As AcadEntity
   
9.    
   
10.     On Error GoTo ErrTrap
    
11.     If Name = "" Then Exit Function
    
12.     For Each EntObj In ThisDrawing.ModelSpace
    
13.         If StrComp(EntObj.Layer, Name, vbTextCompare) = 0 Then
    
14.            LayerRefExist = True
    
15.            Exit For
    
16.         End If
    
17.     Next
    
18.     Set EntObj = Nothing
    
19.     Exit Function
    
20.    
    
21. ErrTrap:
    
22.     If Not (EntObj Is Nothing) Then Set EntObj = Nothing
    
23.     On Error GoTo 0
    
24. End Function
    
25.   [/FONT]
    

<br />   [FONT=courier new]<br /> '检查层引用是否存在<br /> '输入：Name-层名<br /> 输出：LayerRefExist，TRUE表示层引用存在<br /> Public Function LayerRefExist(ByVal Name As String) As Boolean<br />     Dim EntObj As AcadEntity<br />     <br />     On Error GoTo ErrTrap<br />     If Name = "" Then Exit Function<br />     For Each EntObj In ThisDrawing.ModelSpace<br />         If StrComp(EntObj.Layer, Name, vbTextCompare) = 0 Then<br />            LayerRefExist = True<br />            Exit For<br />         End If<br />     Next<br />     Set EntObj = Nothing<br />     Exit Function<br />     <br /> ErrTrap:<br />     If Not (EntObj Is Nothing) Then Set EntObj = Nothing<br />     On Error GoTo 0<br /> End Function<br />   [/FONT]<br />