[LISP程序]：删除空组及单实体组/删除所有组/删匿名组

eachy

以前用 vla 方法写过，今天用 Lisp 又试写了一遍。Vla 方法删除空组程序到理正建筑论坛搜索

2. 
   
3. ;;删除空组及实体数量为1的组
   
4. (defun c:DelNullgrp (/ grp gr el gl)
   
5.   (if (and (setq el (dictsearch (namedobjdict) "ACAD_GROUP"))
   
6.            (setq grp (assoc 3 el))
   
7.       )
   
8.     (progn
   
9.       (setq el (cdr (member grp el)))
   
10.       (while el
    
11.         (if (and (setq gl (entget (setq gr (cdar el))))
    
12.                  (< (length (member (assoc 340 gl) gl)) 2)
    
13.             )
    
14.           (entdel gr)
    
15.           (setq el (cddr el))
    
16.         ) ;_if
    
17.       ) ;_while
    
18.     ) ;_progn
    
19.   ) ;_if
    
20.   (princ)
    
21. )
    
22. ;;删除所有匿名组
    
23. (defun c:Delunnamegrp (/ el n grp)
    
24.   (if (and (setq el (dictsearch (namedobjdict) "ACAD_GROUP"))
    
25.            (setq grp (assoc 3 el))
    
26.       )
    
27.     (progn
    
28.       (setq el (member grp el))
    
29.       (while (setq n (car el))
    
30.         (if (= (substr (cdr n) 1 1) "*")
    
31.           (entdel (cdadr el))
    
32.         ) ;_if
    
33.         (setq el (cddr el))
    
34.       ) ;_while
    
35.     ) ;_progn
    
36.   ) ;_if
    
37.   (princ)
    
38. )
    
39. ;;删除所有组
    
40. (defun c:DelAllGrp (/ grp el)
    
41.   (if (and (setq el (dictsearch (namedobjdict) "ACAD_GROUP"))
    
42.            (setq grp (assoc 3 el))
    
43.       )
    
44.     (progn
    
45.       (setq el (cdr (member grp el)))
    
46.       (while el
    
47.         (entdel (cdar el))
    
48.         (setq el (cddr el))
    
49.       ) ;_while
    
50.     ) ;_progn
    
51.   ) ;_if
    
52.   (princ)
    
53. )

<br /> ;;删除空组及实体数量为1的组<br /> (defun c:DelNullgrp (/ grp gr el gl)<br />   (if (and (setq el (dictsearch (namedobjdict) "ACAD_GROUP"))<br />            (setq grp (assoc 3 el))<br />       )<br />     (progn<br />       (setq el (cdr (member grp el)))<br />       (while el<br />         (if (and (setq gl (entget (setq gr (cdar el))))<br />                  (< (length (member (assoc 340 gl) gl)) 2)<br />             )<br />           (entdel gr)<br />           (setq el (cddr el))<br />         ) ;_if<br />       ) ;_while<br />     ) ;_progn<br />   ) ;_if<br />   (princ)<br /> )<br /> ;;删除所有匿名组<br /> (defun c:Delunnamegrp (/ el n grp)<br />   (if (and (setq el (dictsearch (namedobjdict) "ACAD_GROUP"))<br />            (setq grp (assoc 3 el))<br />       )<br />     (progn<br />       (setq el (member grp el))<br />       (while (setq n (car el))<br />         (if (= (substr (cdr n) 1 1) "*")<br />           (entdel (cdadr el))<br />         ) ;_if<br />         (setq el (cddr el))<br />       ) ;_while<br />     ) ;_progn<br />   ) ;_if<br />   (princ)<br /> )<br /> ;;删除所有组<br /> (defun c:DelAllGrp (/ grp el)<br />   (if (and (setq el (dictsearch (namedobjdict) "ACAD_GROUP"))<br />            (setq grp (assoc 3 el))<br />       )<br />     (progn<br />       (setq el (cdr (member grp el)))<br />       (while el<br />         (entdel (cdar el))<br />         (setq el (cddr el))<br />       ) ;_while<br />     ) ;_progn<br />   ) ;_if<br />   (princ)<br /> )

和 vl-remove 功能一样的 Lisp 实现

2. 
   
3. (defun vll-remove (A L /)
   
4.   (apply 'append
   
5.          (mapcar '(lambda (x)
   
6.                     (if        (not (equal x A))
   
7.                       (list x)
   
8.                     )
   
9.                   )
   
10.                  L
    
11.          )
    
12.   )
    
13. )

<br /> (defun vll-remove (A L /)<br />   (apply 'append<br />          (mapcar '(lambda (x)<br />                     (if        (not (equal x A))<br />                       (list x)<br />                     )<br />                   )<br />                  L<br />          )<br />   )<br /> )

狂刀

2. 
   
3.   [FONT=courier new]
   
4. ;; 删除空组.---by 狂刀.2005.10
   
5. (defun c:gpclr (/ lst)
   
6.   (setq *grp (vla-get-groups (vla-get-activedocument(vlax-get-acad-object))))
   
7.   (vlax-for x *grp (if (= 0 (vla-get-count x))
   
8.                      (progn (setq lst(cons (vla-get-name x) lst))
   
9.                        (vla-delete x))
   
10.                      )
    
11.     )
    
12. (print "\n 已经删除空组:")
    
13. (reverse lst)
    
14. )
    
15.   [/FONT]
    

<br />   [FONT=courier new]<br /> ;; 删除空组.---by 狂刀.2005.10<br /> (defun c:gpclr (/ lst)<br />   (setq *grp (vla-get-groups (vla-get-activedocument(vlax-get-acad-object))))<br />   (vlax-for x *grp (if (= 0 (vla-get-count x))<br />                      (progn (setq lst(cons (vla-get-name x) lst))<br />                        (vla-delete x))<br />                      )<br />     ) <br /> (print "\n 已经删除空组:")<br /> (reverse lst)<br /> )<br />   [/FONT]<br />

adisonmaster

如何获取一个图元所在的组名？

hdtmzs

这个好用，太感谢了。

31475425

太感谢了

snowpeakdream

这个好用，太感谢了。