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

Lisphk

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

1. (defun c:x2l(/ *AcadDoc* s x old new lst nom)
   
2.   (vl-load-com)
   
3.   (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))
   
4.     s ""
   
5.   )
   
6.   (vla-startundomark *AcadDoc*)
   
7.   (vlax-for x (vla-get-blocks *AcadDoc*)
   
8.     (and (eq (vla-get-isxref x) :vlax-true)
   
9.       (setq s (strcat s (vla-get-name x) ","))
   
10.     )
    
11.   )
    
12.   (or    (= s "")
    
13.     (not (ssget "x" (list (cons 0 "insert") (cons 2 s))))
    
14.     (initget 0 "Yes No")
    
15.     (eq (getkword "\nXRefs To Layers\nLock XRef layers? [Yes/No] <Yes>: ") "No")
    
16.     (progn
    
17.       (vlax-for x (setq ss (vla-get-activeselectionset *AcadDoc*))
    
18.     (vla-put-lock (vla-item (vla-get-layers *AcadDoc*) (setq nom (vla-get-layer x))) :vlax-true)
    
19.     (if (setq old (assoc nom lst))
    
20.       (setq new (cons (car old) (1+ (cdr old)))
    
21.         lst (subst new old lst)
    
22.       )
    
23.       (setq lst (cons (cons nom 1) lst))
    
24.     )
    
25.       )
    
26.       (vla-delete ss)
    
27.       (alert (apply 'strcat
    
28.             (mapcar '(lambda (x) (strcat "\n"
    
29.                          (itoa (cdr x))
    
30.                          " XRef(s) on layer: \""
    
31.                          (car x)
    
32.                          "\""
    
33.                      )
    
34.                 )
    
35.                 (vl-sort lst '(lambda(a b)(< (car a) (car b))))
    
36.             )
    
37.          )
    
38.       )
    
39.     )
    
40.   )
    
41.   (vla-endundomark *AcadDoc*)
    
42.   (princ)
    
43. )

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

sicky111

支持楼主源码。

yoyoho

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

alliuyx

源码当然是取直接的。

longer1000

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