求一个“块改零层”的程序

sinommw · 发表于 2014-2-12 22:45:35

求高手帮忙写一个LISP，预实现如下效果：输入命令BT后，将块内所有对象更改到0图层，颜色随层。小弟先再此谢谢了！

flyfox1047 · 发表于 2014-2-12 23:12:58

(defun c:tt ( / e i l n s x )
(if (setq s (ssget '((0 . "INSERT"))))
(repeat (setq i (sslength s))
(if (not (member (setq n (cdr (assoc 2 (entget (ssname s (setq i (1- i))))))) l))
(progn
(setq e (tblobjname "block" n)
l (cons n l)
)
(while (setq e (entnext e))
(setq x (entget e))
(entmod (subst '(8 . "0") (assoc 8 x) x))
)
)
)
)
)
(command "_.regen")
(princ)
)

sinommw · 发表于 2014-2-12 23:36:36

flyfox1047 发表于 2014-2-12 23:12

感谢回复。程序我刚才试过了，针对块内只有单一图层时程序没问题，如果原图块中天正墙体时，会直接关闭CAD而不弹出任何提示，包括错误报告也没有。

flyfox1047 · 发表于 2014-2-12 23:51:29

sinommw 发表于 2014-2-12 23:36
感谢回复。程序我刚才试过了，针对块内只有单一图层时程序没问题，如果原图块中天正墙体时，会直接关闭CA ...

应该是你CAD问题吧

flyfox1047 · 发表于 2014-2-12 23:52:06

(defun c:test (/ *error* adoc lst_layer func_restore-layers)
(defun *error* (msg)
(func_restore-layers)
(vla-endundomark adoc)
(princ msg)
(princ)
) ;_ end of defun
(defun func_restore-layers ()
(foreach item lst_layer
(vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
(vl-catch-all-apply
'(lambda ()
(vla-put-freeze
(car item)
(cdr (assoc "freeze" (cdr item)))
) ;_ end of vla-put-freeze
) ;_ end of lambda
) ;_ end of vl-catch-all-apply
) ;_ end of foreach
) ;_ end of defun
(vl-load-com)
(vla-startundomark
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
) ;_ end of vla-startundomark
(if (and (not (vl-catch-all-error-p
(setq selset
(vl-catch-all-apply
(function
(lambda ()
(ssget '((0 . "INSERT")))
) ;_ end of lambda
) ;_ end of function
) ;_ end of vl-catch-all-apply
) ;_ end of setq
) ;_ end of vl-catch-all-error-p
) ;_ end of not
selset
) ;_ end of and
(progn
(vlax-for item (vla-get-layers adoc)
(setq
lst_layer (cons (list item
(cons "lock" (vla-get-lock item))
(cons "freeze" (vla-get-freeze item))
) ;_ end of list
lst_layer
) ;_ end of cons
) ;_ end of setq
(vla-put-lock item :vlax-false)
(vl-catch-all-apply
'(lambda () (vla-put-freeze item :vlax-false))
) ;_ end of vl-catch-all-apply
) ;_ end of vlax-for
(foreach blk_def
(mapcar
(function
(lambda (x)
(vla-item (vla-get-blocks adoc) x)
) ;_ end of lambda
) ;_ end of function
((lambda (/ res)
(foreach item (mapcar
(function
(lambda (x)
(vla-get-name
(vlax-ename->vla-object x)
) ;_ end of vla-get-name
) ;_ end of lambda
) ;_ end of function
((lambda (/ tab item)
(repeat (setq tab nil
item (sslength selset)
) ;_ end setq
(setq
tab
(cons
(ssname selset
(setq item (1- item))
) ;_ end of ssname
tab
) ;_ end of cons
) ;_ end of setq
) ;_ end of repeat
tab
) ;_ end of lambda
)
) ;_ end of mapcar
(if (not (member item res))
(setq res (cons item res))
) ;_ end of if
) ;_ end of foreach
(reverse res)
) ;_ end of lambda
)
) ;_ end of mapcar
(vlax-for ent blk_def
(vla-put-layer ent "0")
(vla-put-color ent 0)
(vla-put-lineweight ent aclnwtbyblock)
(vla-put-linetype ent "byblock")
) ;_ end of vlax-for
) ;_ end of foreach
(func_restore-layers)
(vla-regen adoc acallviewports)
) ;_ end of progn
) ;_ end of if
(vla-endundomark adoc)
(princ)
) ;_ end of defun

(defun c:test (/ *error* adoc lst_layer func_restore-layers) 
 
  (defun *error* (msg) 
    (func_restore-layers) 
    (vla-endundomark adoc) 
    (princ msg) 
    (princ) 
    ) ;_ end of defun 
 
  (defun func_restore-layers () 
    (foreach item lst_layer 
      (vla-put-lock (car item) (cdr (assoc "lock" (cdr item)))) 
      (vl-catch-all-apply 
        '(lambda () 
           (vla-put-freeze 
             (car item) 
             (cdr (assoc "freeze" (cdr item))) 
             ) ;_ end of vla-put-freeze 
           ) ;_ end of lambda 
        ) ;_ end of vl-catch-all-apply 
      ) ;_ end of foreach 
    ) ;_ end of defun 
 
  (vl-load-com) 
  (vla-startundomark 
    (setq adoc (vla-get-activedocument (vlax-get-acad-object))) 
    ) ;_ end of vla-startundomark 
  (if (and (not (vl-catch-all-error-p 
                  (setq selset 
                         (vl-catch-all-apply 
                           (function 
                             (lambda () 
                               (ssget '((0 . "INSERT"))) 
                               ) ;_ end of lambda 
                             ) ;_ end of function 
                           ) ;_ end of vl-catch-all-apply 
                        ) ;_ end of setq 
                  ) ;_ end of vl-catch-all-error-p 
                ) ;_ end of not 
           selset 
           ) ;_ end of and 
    (progn 
      (vlax-for item (vla-get-layers adoc) 
        (setq 
          lst_layer (cons (list item 
                                (cons "lock" (vla-get-lock item)) 
                                (cons "freeze" (vla-get-freeze item)) 
                                ) ;_ end of list 
                          lst_layer 
                          ) ;_ end of cons 
          ) ;_ end of setq 
        (vla-put-lock item :vlax-false) 
        (vl-catch-all-apply 
          '(lambda () (vla-put-freeze item :vlax-false)) 
          ) ;_ end of vl-catch-all-apply 
        ) ;_ end of vlax-for 
      (foreach blk_def 
               (mapcar 
                 (function 
                   (lambda (x) 
                     (vla-item (vla-get-blocks adoc) x) 
                     ) ;_ end of lambda 
                   ) ;_ end of function 
                 ((lambda (/ res) 
                    (foreach item (mapcar 
                                    (function 
                                      (lambda (x) 
                                        (vla-get-name 
                                          (vlax-ename->vla-object x) 
                                          ) ;_ end of vla-get-name 
                                        ) ;_ end of lambda 
                                      ) ;_ end of function 
                                    ((lambda (/ tab item) 
                                       (repeat (setq tab  nil 
                                                     item (sslength selset) 
                                                     ) ;_ end setq 
                                         (setq 
                                           tab 
                                            (cons 
                                              (ssname selset 
                                                      (setq item (1- item)) 
                                                      ) ;_ end of ssname 
                                              tab 
                                              ) ;_ end of cons 
                                           ) ;_ end of setq 
                                         ) ;_ end of repeat 
                                       tab 
                                       ) ;_ end of lambda 
                                     ) 
                                    ) ;_ end of mapcar 
                      (if (not (member item res)) 
                        (setq res (cons item res)) 
                        ) ;_ end of if 
                      ) ;_ end of foreach 
                    (reverse res) 
                    ) ;_ end of lambda 
                  ) 
                 ) ;_ end of mapcar 
        (vlax-for ent blk_def 
          (vla-put-layer ent "0") 
          (vla-put-color ent 0) 
          (vla-put-lineweight ent aclnwtbyblock) 
          (vla-put-linetype ent "byblock") 
          ) ;_ end of vlax-for 
        ) ;_ end of foreach 
      (func_restore-layers) 
      (vla-regen adoc acallviewports) 
      ) ;_ end of progn 
    ) ;_ end of if 
  (vla-endundomark adoc) 
  (princ) 
  ) ;_ end of defun

sinommw · 发表于 2014-2-13 12:49:38

提示Automation 错误。图层无效

xiongqunan · 发表于 2014-2-13 16:10:48

第一的一个程式感觉也很不错！兄弟幸苦了。

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

[提问] 求一个“块改零层”的程序

相关帖子

评分

浏览过的版块