[LISP程序]：几个常用层处理实用程序

hqd9639 · 发表于 2003-7-17 16:41:26

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

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

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

zhang8755 · 发表于 2003-7-17 18:20:36

再来一个关闭除所选实体所在层以外的所有层，怎么样？

00lg · 发表于 2003-7-18 23:24:51

你们的想法很有用，但是在R14的BOUNS里面全都有啊。还可以定义快捷键的，用起来十分方便的，不用编这几个LISP了

aeo · 发表于 2003-7-19 15:31:33

最初由 zhang8755 发布
[B]再来一个关闭除所选实体所在层以外的所有层，怎么样？ [/B]

(defun c:lnn(/ q)
(setq q(car(entsel "pick:")))
(setq q(cdr(assoc 8(entget q))))
(setvar "CLAYER" q)
(command "-layer" "off" "*" "n" "")
)

degucn · 发表于 2003-7-19 17:35:49

太谢谢，最近我正为这个发愁呢！
现在终于可以解决了！

sqmjk01 · 发表于 2003-7-27 08:46:19

哈哈，又是关于ActiveX的，谢谢各位了！

cxzr8 · 发表于 2004-3-4 15:04:10

express中的工具

andyhua5240 · 发表于 2004-3-4 15:53:03

大侠们能不能整理一下呀，我只会下载附件呀！
谢谢了。

ywx0576 · 发表于 2004-3-5 20:16:18

想锁定除所选实体所在层以外的所有层，怎么编？

cxzr8 · 发表于 2004-3-7 12:32:49

最初由 andyhua5240 发布
[B]大侠们能不能整理一下呀，我只会下载附件呀！
谢谢了。 [/B]

那你怎么用LISP啊
复制代码，保存到记事本中，将其存为 xxx.lsp 即可！！

罗趣 · 发表于 2004-3-7 20:33:14

8楼的看附件里有所有的程序！

蓝山咖啡 · 发表于 2004-12-17 00:12:18

如果选中的图元包含在块中，并且图元跟块不在一个层，就只能对块所在图层进行操作。

可不可以对块中的图元也进行操作呢？

ss1025 · 发表于 2004-12-17 13:21:49

回9楼的朋友
(defun c:Lpk( / ent lname)
  (setvar "cmdecho" 0)
  (setq ent (entsel "\nPick an entity on the target layer: "))
  (if ent (progn
(setq ent (entget (car ent)))
(setq lname (cdr (assoc 8 ent)))
(setvar "clayer" lname)
  )) ;if ent
  (command "layer" "lock" "*" "" "" "n" "")
  (command "layer" "unlock" lname "")
  (princ)
)

xxxcad · 发表于 2004-12-17 15:33:42

thanks

ruan_gdqf · 发表于 2004-12-17 21:53:11

各位请看我的删除图层的原码程序。比楼主的要简单太多了。而且R14可用。
请查看我的贴子。

账号		自动登录	找回密码
密码			立即注册

[LISP程序]：几个常用层处理实用程序

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子