[编程交流] 清除lisp例程增强

(defun c:clear ( / a b ent enx lst )
   (setq ent (entnext))
   (while ent
       (foreach dxf (entget ent)
           (setq a (car dxf)
                 b (cdr dxf)
           )
           (cond
               (   (or (= 'ename (type b)) (= a 5)))
               (   (listp b)
                   (setq enx (cons (cons a (mapcar (function (lambda ( x ) (rtos x 2 )) b)) enx))
               )
               (   (numberp b)
                   (setq enx (cons (cons a (rtos b 2 ) enx))
               )
               (   (setq enx (cons dxf enx)))
           )
       )
       (if (member enx lst)
           (entdel ent)
           (setq lst (cons enx lst))
       )
       (setq ent (entnext ent)
             enx nil
       )
   )
   (princ)
)

(defun c:clear ( / a b ent enx i lst s )
   (if (setq s (ssget "_:L"))
       (repeat (setq i (sslength s))
           (foreach dx (entget (setq ent (ssname s (setq i (1- i)))))
               (setq a (car dx)
                     b (cdr dx)
               )
               (cond
                   (   (or (= 'ename (type b)) (= a 5)))
                   (   (listp b)
                       (setq enx (cons (cons a (mapcar (function (lambda ( x ) (rtos x 2 )) b)) enx))
                   )
                   (   (numberp b)
                       (setq enx (cons (cons a (rtos b 2 ) enx))
                   )
                   (   (setq enx (cons dx enx)))
               )
           )
           (if (member enx lst)
               (entdel ent)
               (setq lst (cons enx lst))
           )
           (setq enx nil)
       )
   )
   (princ)
)

; clear.lsp: Delete duplicate entities, tested only on polylines and circles.
; Core routine by Lee Mac 04-08-2013
; Output results by Luigi Calderone 04-10-2013
;
(defun c:clear (/ old a b ent enx i lst s)
 (setq    xmin (car (getvar "EXTMIN"))
   xmax (car (getvar "EXTMAX"))
   ymin (car (cdr (getvar "EXTMIN")))
   ymax (car (cdr (getvar "EXTMAX")))
   old  (ssget "_X")
   N    10
   J    0
 )
 (command "zoom" "e")
 (prompt "\n")
 (while (< J N)
   (setq lst nil
     s   nil
     pt1 (list xmin (+ ymin (/ (* (- ymax ymin) J) N)))
     pt2 (list xmax (+ ymin (/ (* (- ymax ymin) (+ J 1)) N)))
     J   (+ J 1)
   )
   (if    (setq s (ssget "_C" pt2 pt1))
     (repeat (setq i (sslength s))
   (foreach dx (entget (setq ent (ssname s (setq i (1- i)))))
     (setq    a (car dx)
       b (cdr dx)
     )
     (cond
       ((or (= 'ename (type b)) (= a 5)))
       ((listp b)
        (setq
          enx (cons
            (cons
              a
              (mapcar (function (lambda (x) (rtos x 2 )) b)
            )
            enx
          )
        )
       )
       ((numberp b)
        (setq enx (cons (cons a (rtos b 2 ) enx))
       )
       ((setq enx (cons dx enx)))
     )
   )
   (if (member enx lst)
     (entdel ent)
     (setq lst (cons enx lst))
   )
   (setq enx nil)
   (cond (SPIN (setq SPIN NIL) (princ "\r\"))
         (t
          (setq SPIN (princ "\r/")
            SPIN (princ " ")
            SPIN (princ (itoa J))
            SPIN (princ "/")
            SPIN (princ (itoa N))
          )
         )
   )
     )
   )
 )
 (if (setq trap old)
   (prompt (strcat "\nNumber of elements before clearing- "
           (itoa (sslength old))
       )
   )
   (prompt (strcat "\nNumber of elements before clearing- 0"))
 )
 (if (setq trap (ssget "_X"))
   (prompt (strcat "\nNumber of elements after clearing- "
           (itoa (sslength (ssget "_X")))
       )
   )
   (prompt (strcat "\nNumber of elements after clearing- 0"))
  )    
 (if (setq trap (ssget "_X"))  
   (prompt (strcat "\nNumber of elements cleared- "
         (itoa (- (sslength old) (sslength (ssget "_X"))))
           )
   )
   (prompt (strcat "\nNumber of elements cleared- 0"))
 )
   (princ)
);end file
 (prompt "\nLoaded new command CLEAR. ")
 (princ)

(defun C:CLEARs () ; 11 . 04 . 2013 .
(princ "\n   Selects objects to Checked  : ")
(if (setq sel (ssget) ) ;_ end of setq
 (progn
  (setq lsel (sslength sel)  lseli lsel  i 0  k 0) ;_ end of setq
  (princ (strcat "\n   Selected Items  :  " (itoa lsel) "  ;"))
  (while (< i lsel)
   (princ (strcat "\n   Compare Object  :  " (itoa i) "  ;"))
   (setq lobi (entget (ssname sel i))  lobii (member (assoc 410 lobi) lobi)  j (1+ i) ) ;_ end
   (while (< j lsel)
    (setq nmoj (ssname sel j)  lobj (entget nmoj)  lobjj (member (assoc 410 lobj) lobj) ) ;_ end 
    (if (equal lobii lobjj 0.000001)
     (progn
      (setq sel (ssdel nmoj sel)  k (1+ k) ) ;_ end of setq
      (princ (strcat "\n   Delete Object Namber  :  " (itoa j) "  from  " (itoa lsel) "  =  " (itoa k) "  ;"))
      (setq lsel (1- lsel) ) ;_ end of setq
      (entdel nmoj)
     ) ;_ end of prog then
     (setq j (1+ j)) ;_ end of setq
    ) ;_ end of if
   ) ;_ end of wh j
   (setq i (1+ i)) ;_ end of setq
  ) ;_ end of wh i
)) ;_ end of if sel
(setq texte (strcat "\n\n   Selected Items  :  " (itoa lseli) "  ;"
                        "\n   Delete Objects  :  " (itoa k) "  ;" )) ;_ end of setq
(princ texte) (princ)
) ;_ end of defun 

; (princ (strcat "\n   Compare Object  :  " (itoa i) "  ;"))
. . . 
; (princ (strcat "\n   Delete Object  :  " (itoa j) "  from  " (itoa i) "  =  " (itoa k) "  ;"))