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

(T   (progn (princ "\r/") (princ " ") (princ (itoa J)) (princ "/") (setq SPIN (princ (itoa N))   )
       )
)

(setq SPIN (strcat "\r/  " (itoa J) "/" (itoa N)) )
(princ SPIN)
          

; clear.lsp: Delete duplicate entities, tested only on polylines and circles.
; Core routine by Lee Mac 04-08-2013
; Output results by Luigi Calderone and Costinbos77 04-11-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 (strcat "\r/  " (itoa J) "/" (itoa N)) )
              (princ SPIN)           
         )
   )
     )
   )
 )
 (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)

(princ (strcat "\r/  " (itoa J) "/" (itoa N)) )

; clear.lsp: Delete duplicate entities, tested on polylines, circles,
; mtexts texts, lines, splines, arcs, ellipses, ellipse arcs.
;
; Core routine by Lee Mac 04-08-2013
; Output results refined by Luigi Calderone and Costinbos77 04-11-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)
   (princ "\r\")
   (princ (strcat "\r/  " (itoa J) "/" (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:CLEARsA () ; 21 . 04 . 2013 .
(setq psj (getpoint "\n   Delineates  Processed  Area !\n   Select  the  Bottom - Left  Corner  :  <  Pick  >  :  ")  texte ""
      pds (getcorner psj "\n   Select  the Top - Right  Corner  :  <  Pick  >  :  ")  slsel 0  sk 0) ;_ end of setq
(foreach el '("ARC" "CIRCLE" "ELLIPSE" "INSERT" "LINE" "POLYLINE" "REGION" "SPLINE" 
                   "TABLE" "MTEXT" "TEXT")
 (princ (strcat "\n   Object  TYPE  to  Checked  :  " el "  ;"))
 (if (setq k 0  sel (ssget "_W" psj pds (list (cons 0 el)) ) ) ;_ end of setq
  (progn
   (setq lsel (sslength sel)  slsel (+ lsel slsel)  i 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 100 lobi) lobi)  j (1+ i) ) ;_ end of setq
    (while (< j lsel)
     (setq nmoj (ssname sel j)  lobj (entget nmoj)  lobjj (member (assoc 100 lobj) lobj) ) ;_ end of setq
     (if (equal lobii lobjj 0.000001)
      (progn[color=red] (command "zoom" "o" nmoj "")[/color]
       (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) ;(alert (strcat "S-a  Sters  Obiectul  :  " (itoa k) "  ;" ))
      ) ;_ 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 prog then
  (setq lsel 0) ;_ end of setq
 ) ;_ end of if sel
 (setq texte (strcat texte "\n   Type  :  " el "  =  " (itoa lsel) "  :   Deleted  :  " (itoa k) "  ;" )  sk (+ k sk)) ;_ end of setq
) ;_ end of f
(setq texte (strcat "\n\n   Selected  Items  :  " (itoa slsel) "  ;" texte "\n   Deleted  Objects  :  " (itoa sk) "  .")) ;_ end of
(princ texte) (textscr) (princ)
) ;_ end of defun