删除块属性

eachy

另外一个帖子http://www.xdcad.net/forum/forum.php?mod=viewthread&tid=459431

1. (vl-load-com)
   
2. (defun c:killatt (/ thisdrawing ss ssl e bn bnl elst obj blocks)
   
3.   (setq thisdrawing
   
4.   (vla-get-activedocument (vlax-get-acad-object))
   
5.   )
   
6.   (vla-startundomark thisdrawing)
   
7.   (vl-catch-all-apply
   
8.     '(lambda (/ ss ssl e bn bnl elst obj blocks)
   
9.        (if (setq ss (ssget '((0 . "insert") (66 . 1))))
   
10.   (progn
    
11.     (setq ssl (sslength ss))
    
12.     (while (> ssl 0)
    
13.       (setq e  (ssname ss (setq ssl (1- ssl)))
    
14.      bn (cdr (assoc 2 (setq el (entget e))))
    
15.       )
    
16.       (if (member bn bnl)
    
17.         nil
    
18.         (setq bnl (cons bn bnl))
    
19.       )
    
20.       (setq
    
21.         elst
    
22.   (cons
    
23.     (vl-remove-if-not
    
24.       '(lambda (x)
    
25.          (vl-position (car x) '(0 2 8 10 50 41 42 43))
    
26.        )
    
27.       el
    
28.     )
    
29.     elst
    
30.   )
    
31.       )
    
32.       (setq blocks (vla-get-blocks thisdrawing))
    
33.       (mapcar
    
34.         '(lambda (x / i)
    
35.     (vlax-for i (vla-item blocks x)
    
36.       (if (wcmatch (vla-get-objectname i) "*Attri*")
    
37.         (vla-delete i)
    
38.       )
    
39.     )
    
40.   )
    
41.         bnl
    
42.       )
    
43.       (mapcar 'entmake elst)
    
44.       (vl-cmdf ".erase" ss "")
    
45.       (vla-endundomark thisdrawing)
    
46.     )
    
47.   )
    
48.        )
    
49.      )
    
50.   )
    
51.   (vla-endundomark thisdrawing)
    
52.   (princ)
    
53. )
    
54. (princ
    
55.   "\nStart Command With Killatt, eachy[eachy@outlook.com]!"
    
56. )
    
57. (princ)
    

(vl-load-com)<br /> (defun c:killatt (/ thisdrawing ss ssl e bn bnl elst obj blocks)<br />   (setq thisdrawing<br />   (vla-get-activedocument (vlax-get-acad-object))<br />   )<br />   (vla-startundomark thisdrawing)<br />   (vl-catch-all-apply<br />     '(lambda (/ ss ssl e bn bnl elst obj blocks)<br />        (if (setq ss (ssget '((0 . "insert") (66 . 1))))<br />   (progn<br />     (setq ssl (sslength ss))<br />     (while (> ssl 0)<br />       (setq e  (ssname ss (setq ssl (1- ssl)))<br />      bn (cdr (assoc 2 (setq el (entget e))))<br />       )<br />       (if (member bn bnl)<br />         nil<br />         (setq bnl (cons bn bnl))<br />       )<br />       (setq<br />         elst<br />   (cons<br />     (vl-remove-if-not<br />       '(lambda (x)<br />          (vl-position (car x) '(0 2 8 10 50 41 42 43))<br />        )<br />       el<br />     )<br />     elst<br />   )<br />       )<br />       (setq blocks (vla-get-blocks thisdrawing))<br />       (mapcar<br />         '(lambda (x / i)<br />     (vlax-for i (vla-item blocks x)<br />       (if (wcmatch (vla-get-objectname i) "*Attri*")<br />         (vla-delete i)<br />       )<br />     )<br />   )<br />         bnl<br />       )<br />       (mapcar 'entmake elst)<br />       (vl-cmdf ".erase" ss "")<br />       (vla-endundomark thisdrawing)<br />     )<br />   )<br />        )<br />      )<br />   )<br />   (vla-endundomark thisdrawing)<br />   (princ)<br /> )<br /> (princ<br />   "\nStart Command With Killatt, eachy[<a href=\"mailto:eachy@outlook.com\" target=\"_blank\">eachy@outlook.com</a>]!"<br /> )<br /> (princ)<br />

laibinwu

好像有点问题。如果选择多个属性块的话会删的只剩一个块:'(

ysq101

laibinwu 发表于 2013-8-17 11:49
好像有点问题。如果选择多个属性块的话会删的只剩一个块

这么快测试出来了？

相信自己666

感谢分享，感谢分享