移动所有的XREFS到指定的层前缀的层

Lisphk · 发表于 2017-4-27 23:28:16

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

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

×

移动所有的XREFS到指定的层前缀的层，比如："0-XREF_" ，并提示用户是否锁定该层。

(defun c:x2l(/ *AcadDoc* s x old new lst nom)
(vl-load-com)
(setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))
s ""
)
(vla-startundomark *AcadDoc*)
(vlax-for x (vla-get-blocks *AcadDoc*)
(and (eq (vla-get-isxref x) :vlax-true)
(setq s (strcat s (vla-get-name x) ","))
)
)
(or (= s "")
(not (ssget "x" (list (cons 0 "insert") (cons 2 s))))
(initget 0 "Yes No")
(eq (getkword "\nXRefs To Layers\nLock XRef layers? [Yes/No] <Yes>: ") "No")
(progn
(vlax-for x (setq ss (vla-get-activeselectionset *AcadDoc*))
(vla-put-lock (vla-item (vla-get-layers *AcadDoc*) (setq nom (vla-get-layer x))) :vlax-true)
(if (setq old (assoc nom lst))
(setq new (cons (car old) (1+ (cdr old)))
lst (subst new old lst)
)
(setq lst (cons (cons nom 1) lst))
)
)
(vla-delete ss)
(alert (apply 'strcat
(mapcar '(lambda (x) (strcat "\n"
(itoa (cdr x))
" XRef(s) on layer: \""
(car x)
"\""
)
)
(vl-sort lst '(lambda(a b)(< (car a) (car b))))
)
)
)
)
)
(vla-endundomark *AcadDoc*)
(princ)
)

(defun c:x2l(/ *AcadDoc* s x old new lst nom) 
  (vl-load-com) 
  (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)) 
    s "" 
  ) 
  (vla-startundomark *AcadDoc*) 
  (vlax-for x (vla-get-blocks *AcadDoc*) 
    (and (eq (vla-get-isxref x) :vlax-true) 
      (setq s (strcat s (vla-get-name x) ",")) 
    ) 
  ) 
  (or    (= s "") 
    (not (ssget "x" (list (cons 0 "insert") (cons 2 s)))) 
    (initget 0 "Yes No") 
    (eq (getkword "\nXRefs To Layers\nLock XRef layers? [Yes/No] <Yes>: ") "No") 
    (progn 
      (vlax-for x (setq ss (vla-get-activeselectionset *AcadDoc*)) 
    (vla-put-lock (vla-item (vla-get-layers *AcadDoc*) (setq nom (vla-get-layer x))) :vlax-true) 
    (if (setq old (assoc nom lst)) 
      (setq new (cons (car old) (1+ (cdr old))) 
        lst (subst new old lst) 
      ) 
      (setq lst (cons (cons nom 1) lst)) 
    ) 
      ) 
      (vla-delete ss) 
      (alert (apply 'strcat 
            (mapcar '(lambda (x) (strcat "\n" 
                         (itoa (cdr x)) 
                         " XRef(s) on layer: \"" 
                         (car x) 
                         "\"" 
                     ) 
                ) 
                (vl-sort lst '(lambda(a b)(< (car a) (car b)))) 
            ) 
         ) 
      ) 
    ) 
  ) 
  (vla-endundomark *AcadDoc*) 
  (princ) 
)

sicky111 · 发表于 2017-4-28 00:12:16

支持楼主源码。

yoyoho · 发表于 2017-4-28 07:29:05

感谢 Lisphk 分享源码程序!!!!

alliuyx · 发表于 2017-4-28 07:42:18

源码当然是取直接的。

longer1000 · 发表于 2017-4-28 08:48:58

感谢 Lisphk 分享源码程序!!!!

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

[每日一码] 移动所有的XREFS到指定的层前缀的层

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