[转帖]一个图层工具

;;;**************************************************************************<BR>;;;1.删除某个层<BR>(defun c:hqddellayer ()<BR>                (vl-load-com)<BR>                (setq acadObject (vlax-get-acad-object))<BR>                (setq acadDocument (vlax-get-property acadObject 'ActiveDocument))<BR>                (setq LayersObj                (vla-get-layers acadDocument ))<BR>                (setq actlaystr (vla-get-name (vla-get-activeLayer acadDocument)))<BR>                (setq k T)<BR>                (while k<BR>                                                (setq layname (getstring "\n请输入要删除的层名&lt;退出&gt;: "))<BR>                                                (if (/= layname "")<BR>                                                                                (progn                                                                                                 <BR>                                                                                                 (setq vlalay                (vl-catch-all-apply 'vla-item (list LayersObj layname)))<BR>                                                                                                 (if (vl-catch-all-error-p vlalay);;判断层是否存在<BR>                                                                                                                                 (prompt (strcat "\n" layname " 层不存在，请重新输入."))<BR>                                                                                                                                 (progn<BR>                                                                                                                                                                (if (and (/= layname actlaystr) (/= layname "0"))<BR>                                                                                                                                                                                                (progn<BR>                                                                                                                                                                                                                 (if (ssget "X" (list (cons 8 layname)))<BR>                                                                                                                                                                                                                                                 (princ "\n图层中含有实体，不能删除!")<BR>                                                                                                                                                                                                                                                 (progn<BR>                                                                                                                                                                                                                                                                                (vla-delete vlalay)<BR>                                                                                                                                                                                                                                                                                (princ (strcat "\n已成功删除" layname "层!"))<BR>                                                                                                                                                                                                                                                 )<BR>                                                                                                                                                                                                                 )<BR>                                                                                                                                                                                                )<BR>                                                                                                                                                                                                (princ "\n不能当删除前层和 0 层!")<BR>                                                                                                                                                                )                                <BR>                                                                                                                                )<BR>                                                                                                )                                 <BR>                                                                 )<BR>                                                                 (setq k nil)<BR>                                 )<BR>                )<BR>                (princ)<BR>) <BR>;;;**************************************************************************<BR>;;;2.关闭选取实体所在层<BR>(defun c:hqdsellayoff ()<BR>                (vl-load-com)<BR>                (setq acadObject (vlax-get-acad-object))<BR>                (setq acadDocument (vlax-get-property acadObject 'ActiveDocument))<BR>                (setq LayersObj                (vla-get-layers acadDocument ))<BR>                (setq k T)<BR>                (while k<BR>                                                                 (setq                layent                (entsel "\n请选取要关闭层中的一个实体&lt;退出&gt;: "))<BR>                                                                 (if layent <BR>                                                                                                                                (progn<BR>                                                                                                                                                                                (setq                layent                (car                 layent))<BR>                                                                                                                                                                                (setq                layentvla                (vlax-ename-&gt;vla-object                layent)) <BR>                                                                                                                                                                                (setq laystr (vla-get-layer                layentvla))<BR>                                                                                                                                                                                (vla-put-layeron (vla-item LayersObj                laystr) :vlax-False)                                                                                                 <BR>                                                                                                                 )<BR>                                                                                                                 (setq k nil)<BR>                                                                                 )<BR>                )<BR>                (princ)<BR>) <BR>;;;**************************************************************************<BR>;;;3.打开所有层 <BR>(defun c:hqdalllayon ()<BR>                (vl-load-com)<BR>                (setq acadObject (vlax-get-acad-object))<BR>                (setq acadDocument (vlax-get-property acadObject 'ActiveDocument))<BR>                (setq LayersObj                (vla-get-layers acadDocument ))<BR>                (vlax-for lay LayersObj<BR>                                                                 ; (setq layvla (vla-item LayersObj (vla-get-name lay)))<BR>                                                                ; (vla-put-layeron                layvla                :vlax-True)<BR>                                                                 (vla-put-layeron                lay                :vlax-True)<BR>                )<BR>                (princ)<BR>)


;;;**************************************************************************<BR>;;;4.冻结选取实体所在层 <BR>(defun c:hqdsellayfreeze ()<BR>                (vl-load-com)<BR>                (setq acadObject (vlax-get-acad-object))<BR>                (setq acadDocument (vlax-get-property acadObject 'ActiveDocument))<BR>                (setq LayersObj                (vla-get-layers acadDocument ))<BR>                (setq k T)<BR>                (while k<BR>                                                                                                (setq                layent                (entsel "\n请选取要冻结层中的一个实体&lt;退出&gt;: "))<BR>                                                                                                (if                 layent <BR>                                                                                                                                (progn<BR>                                                                                                                                                                                (setq                layent                (car                 layent))<BR>                                                                                                                                                                                (setq                layentvla                (vlax-ename-&gt;vla-object                layent)) <BR>                                                                                                                                                                                (setq laystr (vla-get-layer                layentvla))<BR>                                                                                                                                                                                (setq actlaystr (vla-get-name (vla-get-activeLayer acadDocument)))<BR>                                                                                                                                                                                (if ( /=                 laystr                actlaystr)<BR>                                                                                                                                                                                                                (vla-put-freeze (vla-item LayersObj                laystr) :vlax-True)<BR>                                                                                                                                                                                                                (princ "\n不能冻结当前层!")<BR>                                                                                                                                                                 )                                                                                <BR>                                                                                                                 )<BR>                                                                                                                 (setq k nil)<BR>                                                                                 )<BR>                )<BR>                (princ)<BR>) <BR>;;;**************************************************************************<BR>;;;5.解冻所有层 <BR>(defun c:hqdallfreeze ()<BR>                 (vl-load-com)<BR>                (setq acadObject (vlax-get-acad-object))<BR>                (setq acadDocument (vlax-get-property acadObject 'ActiveDocument))<BR>                (setq LayersObj                (vla-get-layers acadDocument ))<BR>                (setq actlaystr (vla-get-name (vla-get-activeLayer acadDocument)))<BR>                (vlax-for lay LayersObj<BR>                                                                                                 (if ( /=                 (vla-get-name lay)                actlaystr)<BR>                                                                                                                                 (vla-put-freeze                lay :vlax-false)<BR>                                                                                                )<BR>                )<BR>(vla-regen acadDocument acAllViewPorts)<BR>                (princ)<BR>)<BR>;;;**************************************************************************<BR>;;;6.锁定或解锁选取实体所在层 <BR>(defun c:hqdsellaylock ()<BR>                (vl-load-com)<BR>                (setq acadObject (vlax-get-acad-object))<BR>                (setq acadDocument (vlax-get-property acadObject 'ActiveDocument))<BR>                (setq LayersObj                (vla-get-layers acadDocument ))<BR>                (setq k T)<BR>                (while k<BR>                                                                                                (setq                layent                (entsel "\n请选取要锁定或解锁层中的一个实体&lt;退出&gt;: "))<BR>                                                                                                (if                 layent <BR>                                                                                                                                (progn<BR>                                                                                                                                                                                (setq                layent                (car                 layent))<BR>                                                                                                                                                                                (setq                layentvla                (vlax-ename-&gt;vla-object                layent)) <BR>                                                                                                                                                                                (setq laystr (vla-get-layer                layentvla))<BR>                                                                                                                                                                                (setq layvla (vla-item LayersObj                laystr))<BR>                                                                                                                                                                                (setq laylock (vla-get-lock                layvla))<BR>                                                                                                                                                                                (if (=                laylock :vlax-false)<BR>                                                                                                                                                                                                                (progn<BR>                                                                                                                                                                                                                                                                (vla-put-lock                layvla                :vlax-True)<BR>                                                                                                                                                                                                                                                                (princ (strcat "\n" laystr                " 层已锁"))<BR>                                                                                                                                                                                                 )<BR>                                                                                                                                                                                                ( progn<BR>                                                                                                                                                                                                                                                (vla-put-lock                layvla                :vlax-false)<BR>                                                                                                                                                                                                                                                 (princ (strcat "\n"                laystr                " 层已解锁")) <BR>                                                                                                                                                                                 )<BR>                                                                                                                                                                 )                                                                                <BR>                                                                                                                 )<BR>                                                                                                                 (setq k nil)<BR>                                                                                 )<BR>                )<BR>                (princ)<BR>) <BR>;;;**************************************************************************


;;关闭除所选实体所在层以外的所有层<BR>(defun c:lnn(/ q)<BR>(setq q(car(entsel "pick:")))<BR>(setq q(cdr(assoc 8(entget q))))<BR>(setvar "CLAYER" q)<BR>(command "-layer" "off" "*"                "n" "")<BR>)

楼主从哪整地这程序,不错啊,就是太麻烦.一般建了一个图层很少删除阿,