求 删除 绑定参照的 图层、线型、尺寸标注、文字样式的名字前缀

hongxibao

麻烦大侠帮个忙！写个lsp
绑定参照后，把带进的 图层、线型、尺寸标注、文字样式的名字$0$之前的前缀全部删掉（图纸说不定被二次参照，名字带有两个或三个、n个$0$）

删除前缀时，如果有名字重合，则可以合并名字，如果不能合并，就在名字后面加个数字，比如1（加数字后，如果还有重合，继续循环运行加数字1，直到不重合）

437271963

2. (defun c:tes ( / doc msp n obj s2 ss1 ss2 ss3 tc1 tc2 x y)
   
3. (setvar "cmdecho" 0)
   
4. (setvar "blipmode" 0)
   
5. (if (null vlax-dump-object) (vl-load-com) )
   
6. (s1811301);修改图层名称
   
7. (princ)
   
8. )
   
9. 
   
10. 
    
11. ;修改图层名称
    
12. (defun s1811301 ( / doc n obj s2 ss1 ss2 ss3 tc1 tc2 x y)
    
13. (setq doc (vla-get-activedocument (vlax-get-acad-object));取得当前所有对象集合
    
14.        msp (vla-get-ModelSpace doc);取得模型空间
    
15.        ss1 (s1811302 doc msp);取得所有对象
    
16.        ss2 (w1810232 doc);图层集合
    
17.        ss3 (mapcar 'strcase (mapcar 'car ss2));图层名称集合
    
18.        tc1 (getvar "clayer");取得当前图层名称
    
19. )
    
20. (if (or (vl-string-search "\#" tc1 0) (vl-string-search "$" tc1 0)) (setvar "clayer" "0") );如果当前图层需要修改，就转换图层为"0"
    
21. (while (setq s2 (car ss2));处理图层
    
22.   (setq ss2 (cdr ss2) tc1 (car s2) tc2 tc1 obj (cadr s2))
    
23.   (while (vl-string-search "\#" tc2 0) (setq tc2 (vl-string-subst "" "\#" tc2)));处理有#的图层名称
    
24.   (while (setq n (vl-string-search "$" tc2 0)) (setq tc2 (substr tc2 (+ 2 n))));处理有$的图层名称
    
25.   (if (= tc2 "") (setq tc2 "0") );如果是空就修改图层为"0"
    
26.   (if (/= tc2 tc1);如果名称发生变化
    
27.    (progn;;1
    
28.     (if (member (strcase tc2) ss3);2;如果已经有这个图层名称
    
29.      (progn;;2
    
30.       (mapcar '(lambda (y) (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-layer (list y tc2))))
    
31.        (mapcar 'cadr
    
32.         (vl-remove-if-not '(lambda (x) (= (car x) tc1)) ss1);取得所有TC1的对象
    
33.        );提取出图元名称
    
34.       );所有这个图层的所有图元改变图层
    
35.       (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-delete (list obj)));删除这个图层
    
36.        (progn
    
37.         (Command "laymrg" "N" tc1 "" "N" tc2 "Y");如果图层不能删除就合并
    
38.        )
    
39.       );if;4
    
40.      );progn;2-1
    
41.      (progn;;2-2
    
42.       (if (null (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-name (list obj tc2))));如果没有相同命名的图层就改变图层名称
    
43.        (setq ss3 (cons (strcase tc2) ss3))
    
44.       );if;3
    
45.      );progn;2-2
    
46.     );if;2
    
47.    );progn;1
    
48.   );if;1
    
49. );while
    
50. )
    
51. 
    
52. ;取得所有图层名称
    
53. (defun w1810232 (doc / doc lay obj ss tc)
    
54. (setq lay (vla-get-layers doc) ss '())
    
55. (vlax-for obj lay
    
56.   (setq tc (vla-get-name obj));取得图层名称
    
57.   (setq ss (cons (list tc obj) ss))
    
58. )
    
59. ss
    
60. )
    
61. 
    
62. ;提取所有图元
    
63. (defun s1811302 (doc msp / b1 b2 doc msp obj ss tc)
    
64. (setq ss '())
    
65. (vlax-for obj msp;取得所有图元
    
66.   (if (null (vl-catch-all-error-p (setq tc (vl-catch-all-apply 'vla-get-layer (list obj)))))
    
67.     (setq ss (cons (list tc obj) ss))
    
68.   )
    
69. )
    
70. (setq b1 (vla-get-blocks doc));取得所有块集合
    
71. (vlax-for b2 b1;查找出所有块
    
72.   (vlax-for obj b2;块里面所有对象
    
73.    (if (null (vl-catch-all-error-p (setq tc (vl-catch-all-apply 'vla-get-layer (list obj)))))
    
74.     (setq ss (cons (list tc obj) ss))
    
75.    )
    
76.   )
    
77. )
    
78. ss
    
79. )
    
80. 
    
81. ;;一键所有图层去除【$0$】
    
82. ;;-------------------------------------------
    

(defun c:tes ( / doc msp n obj s2 ss1 ss2 ss3 tc1 tc2 x y)<br /> (setvar "cmdecho" 0)<br /> (setvar "blipmode" 0)<br /> (if (null vlax-dump-object) (vl-load-com) )<br /> (s1811301);修改图层名称<br /> (princ)<br /> )<br /> <br /> <br /> ;修改图层名称<br /> (defun s1811301 ( / doc n obj s2 ss1 ss2 ss3 tc1 tc2 x y)<br /> (setq doc (vla-get-activedocument (vlax-get-acad-object));取得当前所有对象集合<br />        msp (vla-get-ModelSpace doc);取得模型空间<br />        ss1 (s1811302 doc msp);取得所有对象<br />        ss2 (w1810232 doc);图层集合<br />        ss3 (mapcar 'strcase (mapcar 'car ss2));图层名称集合<br />        tc1 (getvar "clayer");取得当前图层名称<br /> )<br /> (if (or (vl-string-search "\#" tc1 0) (vl-string-search "$" tc1 0)) (setvar "clayer" "0") );如果当前图层需要修改，就转换图层为"0"<br /> (while (setq s2 (car ss2));处理图层<br />   (setq ss2 (cdr ss2) tc1 (car s2) tc2 tc1 obj (cadr s2))<br />   (while (vl-string-search "\#" tc2 0) (setq tc2 (vl-string-subst "" "\#" tc2)));处理有#的图层名称<br />   (while (setq n (vl-string-search "$" tc2 0)) (setq tc2 (substr tc2 (+ 2 n))));处理有$的图层名称<br />   (if (= tc2 "") (setq tc2 "0") );如果是空就修改图层为"0"<br />   (if (/= tc2 tc1);如果名称发生变化<br />    (progn;;1<br />     (if (member (strcase tc2) ss3);2;如果已经有这个图层名称<br />      (progn;;2<br />       (mapcar '(lambda (y) (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-layer (list y tc2))))<br />        (mapcar 'cadr<br />         (vl-remove-if-not '(lambda (x) (= (car x) tc1)) ss1);取得所有TC1的对象<br />        );提取出图元名称<br />       );所有这个图层的所有图元改变图层<br />       (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-delete (list obj)));删除这个图层<br />        (progn<br />         (Command "laymrg" "N" tc1 "" "N" tc2 "Y");如果图层不能删除就合并<br />        )<br />       );if;4<br />      );progn;2-1<br />      (progn;;2-2<br />       (if (null (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-name (list obj tc2))));如果没有相同命名的图层就改变图层名称<br />        (setq ss3 (cons (strcase tc2) ss3))<br />       );if;3<br />      );progn;2-2<br />     );if;2<br />    );progn;1<br />   );if;1<br /> );while<br /> )<br /> <br /> ;取得所有图层名称<br /> (defun w1810232 (doc / doc lay obj ss tc)<br /> (setq lay (vla-get-layers doc) ss '())<br /> (vlax-for obj lay<br />   (setq tc (vla-get-name obj));取得图层名称<br />   (setq ss (cons (list tc obj) ss))<br /> )<br /> ss<br /> )<br /> <br /> ;提取所有图元<br /> (defun s1811302 (doc msp / b1 b2 doc msp obj ss tc)<br /> (setq ss '())<br /> (vlax-for obj msp;取得所有图元<br />   (if (null (vl-catch-all-error-p (setq tc (vl-catch-all-apply 'vla-get-layer (list obj)))))<br />     (setq ss (cons (list tc obj) ss))<br />   )<br /> )<br /> (setq b1 (vla-get-blocks doc));取得所有块集合<br /> (vlax-for b2 b1;查找出所有块<br />   (vlax-for obj b2;块里面所有对象<br />    (if (null (vl-catch-all-error-p (setq tc (vl-catch-all-apply 'vla-get-layer (list obj)))))<br />     (setq ss (cons (list tc obj) ss))<br />    )<br />   )<br /> )<br /> ss<br /> )<br /> <br /> ;;一键所有图层去除【$0$】<br /> ;;-------------------------------------------<br />

hongxibao

有大侠可以帮忙吗

wrightchen

试用过了，改不了，请大侠复核一下

hongxibao

437271963 发表于 2018-9-16 11:09

谢谢大侠帮助

he378980280

好东西 谢谢

tensir

感谢作者的分享！