修改程序

ymcui2005

2. (defun c:cd (/ ss nss en ent cnt st1 st2 )
   
3. (setq ss1 (ssadd))
   
4.   (if (setq ss (ssget '((0 . "CIRCLE"))))
   
5.     (progn
   
6.       (repeat (setq nss (sslength ss))
   
7.         (setq en  (ssname ss (setq nss (1- nss)))
   
8.               ent (entget en)
   
9.               cnt (cdr (assoc 10 ent))
   
10.               r      (vl-catch-all-apply
    
11.                     '(lambda ()
    
12.                        (foreach    p st1
    
13.                          (if (equal cnt p 1e-6)
    
14.                            (exit)
    
15.                          )
    
16.                        )
    
17.                      )
    
18.                   )
    
19.         )
    
20.         (if    (not (vl-catch-all-error-p r))
    
21.                 (setq    st1 (cons cnt st1)
    
22.                 st2 (cons (cdr (assoc 10 ent)) st2))
    
23.                 (ssadd en ss1)
    
24.         )
    
25.       )
    
26.     )
    
27. 
    
28.   )
    
29. (alert (strcat "已删除" (rtos (- (sslength ss1) nss))"个同心圆"))
    
30. (reverse st2)
    
31. )

(defun c:cd (/ ss nss en ent cnt st1 st2 )<br /> (setq ss1 (ssadd))<br />   (if (setq ss (ssget '((0 . "CIRCLE"))))<br />     (progn<br />       (repeat (setq nss (sslength ss))<br />         (setq en  (ssname ss (setq nss (1- nss)))<br />               ent (entget en)<br />               cnt (cdr (assoc 10 ent))<br />               r      (vl-catch-all-apply<br />                     '(lambda ()<br />                        (foreach    p st1<br />                          (if (equal cnt p 1e-6)<br />                            (exit)<br />                          )<br />                        )<br />                      )<br />                   )<br />         )<br />         (if    (not (vl-catch-all-error-p r))<br />                 (setq    st1 (cons cnt st1)<br />                 st2 (cons (cdr (assoc 10 ent)) st2))<br />                 (ssadd en ss1)<br />         )<br />       )<br />     )<br /> <br />   )<br /> (alert (strcat "已删除" (rtos (- (sslength ss1) nss))"个同心圆"))<br /> (reverse st2)<br /> )

现在的程序是删除小圆保留最大的圆,
请帮忙改成只删除大圆保最小的一个圆.

ysq101

你这程序没有删除什么东西啊

yoyoho

;;;同心圆删除大圆保留最小的圆 O.K.
(defun c:cd (/ ss nss en ent cnt st1 st2 )
(setq ss1 (ssadd))
  (if (setq ss (ssget '((0 . "CIRCLE"))))
    (progn
      (repeat (setq nss (sslength ss))
        (setq en  (ssname ss (setq nss (1- nss)))
              ent (entget en)
              cnt (cdr (assoc 10 ent))
              r      (vl-catch-all-apply
                    '(lambda ()
                       (foreach    p st1
                         (if (equal cnt p 1e-6)
                           (exit)
                         )
                       )
                     )
                  )
        )
        (if    (not (vl-catch-all-error-p r))
                (setq    st1 (cons cnt st1)
                st2 (cons (cdr (assoc 10 ent)) st2))
               (PROGN
                 (ssadd en ss1)
                 (vla-Delete (vlax-ename->vla-object en))
               )
        )

      )
      
    )

  )
(alert (strcat "已删除" (rtos (- (sslength ss1) nss))"个同心圆"))
(reverse st2)
)

Free-Lancer

1. (defun c:tt (/ lst)
   
2.   (fy:begin)
   
3.   (princ "\nSelect Circles .....")
   
4.   (if (ssget '((0 . "circle")))
   
5.     (progn
   
6.       (setq lst        (XD::List:GroupByIndex
   
7.                   (mapcar '(lambda (x)
   
8.                              (list (vlax-get x "Center")
   
9.                                    (list (vlax-get x "Radius") x)
   
10.                              )
    
11.                            )
    
12.                           (fy:cset->objs)
    
13.                   )
    
14.                   1e-3
    
15.                 )
    
16.             lst        (mapcar        '(lambda (x)
    
17.                            (vl-sort x
    
18.                                     '(lambda (x1 x2)
    
19.                                        (< (car x1) (car x2));_改为 > 保留最大圆
    
20.                                      )
    
21.                            )
    
22.                          )
    
23.                         (mapcar 'cdr lst)
    
24.                 )
    
25.       )
    
26.       (mapcar '(lambda (a)
    
27.                  (if (> (length a) 1)
    
28.                    (mapcar 'vla-delete (cdr a))
    
29.                  )
    
30.                )
    
31.               (mapcar '(lambda (x) (mapcar 'cadr x)) lst)
    
32.       )
    
33.     )
    
34.   )
    
35.   (fy:end)
    
36. )

(defun c:tt (/ lst)<br />   (fy:begin)<br />   (princ "\nSelect Circles .....")<br />   (if (ssget '((0 . "circle")))<br />     (progn<br />       (setq lst        (XD::List:GroupByIndex<br />                   (mapcar '(lambda (x)<br />                              (list (vlax-get x "Center")<br />                                    (list (vlax-get x "Radius") x)<br />                              )<br />                            )<br />                           (fy:cset->objs)<br />                   )<br />                   1e-3<br />                 )<br />             lst        (mapcar        '(lambda (x)<br />                            (vl-sort x<br />                                     '(lambda (x1 x2)<br />                                        (< (car x1) (car x2));_改为 > 保留最大圆<br />                                      )<br />                            )<br />                          )<br />                         (mapcar 'cdr lst)<br />                 )<br />       )<br />       (mapcar '(lambda (a)<br />                  (if (> (length a) 1)<br />                    (mapcar 'vla-delete (cdr a))<br />                  )<br />                )<br />               (mapcar '(lambda (x) (mapcar 'cadr x)) lst)<br />       )<br />     )<br />   )<br />   (fy:end)<br /> )

清风明月10

谢谢各位楼主的分享！很有意思的代码，收藏备用。