[LISP程序]：清除重复的实体

mmmm · 发表于 2003-1-26 21:15:39

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

;| Programmed by Dave Aguilar
DUPREM.LSP <c> 1994 Onyx Software
This program creates an list of entity lists for all entities in the
drawing (using the first VERTEX for POLYLINES) and then compares each
entity list with the total list, building a new selection set of all
duplicate entries which are then erased.
it's not guarenteed but try it on a copy of a badly duplicated drawing
and see if it helps.
------------------------------------------------------------------------
------------------------------------------------------------------------
Modified by J. Tippit, SPAUG President 08/25/99
E-mail: [email]cadpres@spaug.org[/email]
Web Site: [url]http://www.spaug.org[/url]
1. Modified to work with R14 & 2000
2. Now prompts for 3 types of selection sets
3. Works on all types of entities (including LWPOLYLINES)
Large donations to SPAUG is appreciated. :)
------------------------------------------------------------------------
------------------------------------------------------------------------
|;
(defun C:DUPREM ()
(setvar "cmdecho" 0)
(setq f1 nil f1 0)
; Added by Jeff Tippit 08/25/99
; Start
(initget "S L E")
(setq SLE (getkword "\nSelect objects by [S] election set, [L]imits, or [E] ntire database: "))
(cond
((= SLE "S")(setq sa (ssget)))
((= SLE "L")(setq sa (ssget "c" (getvar "extmin")(getvar "extmax"))))
((= SLE "E")(setq sa (ssget "X")))
)
; End
(setq ca 0 ta (sslength sa) la nil lb nil)
(while (< ca ta)
(setq enta (ssname sa ca) ea (cdr (entget enta))
typa (cdr (assoc 0 ea))
)
; (if (= typa "POLYLINE") (progn
; (setq entb (entnext enta) ea (cdr (entget entb)))
; ))
; Added by Jeff Tippit 08/25/99
; Updated for R14 & 2000
; Start
(setq a1 (assoc 5 ea))
(setq a2 (cons 5 ""))
(setq ea (subst a2 a1 ea))
(if (wcmatch (getvar "ACADVER") "*15*")
(progn
(setq a3 (assoc 330 ea))
(setq a4 (cons 330 ""))
(setq ea (subst a4 a3 ea))
)
)
; End
(setq la (cons enta la) lb (cons ea lb)
ca (+ ca 1)
)
)
(setq sc nil sc (ssadd) ltest lb)
(setq ca 0)
(setq tes (car ltest) ltest (cdr ltest) ta nil ta (length ltest))
(while (/= ta 0)
(if (member tes ltest) (progn
(setq sc (ssadd (nth ca la) sc))
(prompt "\nFound duplicate entity.")
(setq f1 (+ f1 1))
))
(setq ca (+ ca 1))
(setq tes (car ltest) ltest (cdr ltest) ta (length ltest))
)
(command "erase" sc "")
(redraw)
(prompt "\n")(prin1 f1)(prompt " duplicate entities erased.")
(princ)
)
(prompt "\nType DUPREM to run. Delete duplicate entity routine Ver 2.0 loaded.")
(princ)

;| Programmed by Dave Aguilar 
   DUPREM.LSP <c> 1994 Onyx Software 
 
 This program creates an list of entity lists for all entities in the 
 drawing (using the first VERTEX for POLYLINES) and then compares each 
 entity list with the total list, building a new selection set of all 
 duplicate entries which are then erased. 
 
 it's not guarenteed but try it on a copy of a badly duplicated drawing 
 and see if it helps. 
 
------------------------------------------------------------------------ 
------------------------------------------------------------------------ 
 Modified by J. Tippit, SPAUG President                                08/25/99 
    E-mail:                     [email]cadpres@spaug.org[/email] 
    Web Site:                [url]http://www.spaug.org[/url] 
 
        1. Modified to work with R14 & 2000 
        2. Now prompts for 3 types of selection sets 
        3. Works on all types of entities (including LWPOLYLINES) 
 
 Large donations to SPAUG is appreciated. :) 
------------------------------------------------------------------------ 
------------------------------------------------------------------------ 
 
|; 
 
(defun C:DUPREM () 
   (setvar "cmdecho" 0) 
   (setq f1 nil f1 0) 
; Added by Jeff Tippit 08/25/99 
; Start 
   (initget "S L E") 
   (setq SLE (getkword "\nSelect objects by [S] election set, [L]imits, or [E] ntire database: ")) 
   (cond 
      ((= SLE "S")(setq sa (ssget))) 
      ((= SLE "L")(setq sa (ssget "c" (getvar "extmin")(getvar "extmax")))) 
      ((= SLE "E")(setq sa (ssget "X"))) 
   ) 
; End 
   (setq ca 0 ta (sslength sa) la nil lb nil) 
   (while (< ca ta) 
      (setq enta (ssname sa ca) ea (cdr (entget enta)) 
            typa (cdr (assoc 0 ea)) 
      ) 
;      (if (= typa "POLYLINE") (progn 
;         (setq entb (entnext enta) ea (cdr (entget entb))) 
;      )) 
 
; Added by Jeff Tippit 08/25/99 
; Updated for R14 & 2000 
; Start 
   (setq a1 (assoc 5 ea)) 
   (setq a2 (cons 5 "")) 
   (setq ea (subst a2 a1 ea)) 
   (if (wcmatch (getvar "ACADVER") "*15*") 
      (progn 
         (setq a3 (assoc 330 ea)) 
         (setq a4 (cons 330 "")) 
         (setq ea (subst a4 a3 ea)) 
      ) 
   ) 
; End 
      (setq la (cons enta la) lb (cons ea lb) 
            ca (+ ca 1) 
      ) 
   ) 
   (setq sc nil sc (ssadd) ltest lb) 
   (setq ca 0) 
   (setq tes (car ltest) ltest (cdr ltest) ta nil ta (length ltest)) 
   (while (/= ta 0) 
      (if (member tes ltest) (progn 
         (setq sc (ssadd (nth ca la) sc)) 
         (prompt "\nFound duplicate entity.") 
         (setq f1 (+ f1 1)) 
      )) 
      (setq ca (+ ca 1)) 
      (setq tes (car ltest) ltest (cdr ltest) ta (length ltest)) 
   ) 
   (command "erase" sc "") 
   (redraw) 
   (prompt "\n")(prin1 f1)(prompt " duplicate entities erased.") 
   (princ) 
) 
(prompt "\nType DUPREM to run. Delete duplicate entity routine Ver 2.0 loaded.") 
(princ)

sidney2002 · 发表于 2003-1-27 14:07:05

你這個好用嗎？哪裡找來的，貼一個沒有刪除線的吧！！

kkk3kkk · 发表于 2003-1-28 14:19:06

最初由 mmmm 发布
[B][code]
;| Programmed by Dave Aguilar
DUPREM.LSP <c> 1994 Onyx Software

This program creates an list of entity lists for all entities in the
drawing (using the first VERTEX for POLYLINES) a... [/B]

copy 就能清除

LUCAS · 发表于 2003-2-6 11:52:39

;;這是一個刪除完全重疊物件的程序
;;我也忘了是甚麼時候看到
;;當時只修改了一些就收起來!!
;| Programmed by Dave Aguilar
DUPREM.LSP 1994 Onyx Software
This program creates an list of entity lists for all entities in the
drawing (using the first VERTEX for POLYLINES) and then compares each
entity list with the total list, building a new selection set of all
duplicate entries which are then erased.
it's not guarenteed but try it on a copy of a badly duplicated drawing
and see if it helps.
------------------------------------------------------------------------
------------------------------------------------------------------------
Modified by J. Tippit, SPAUG President 08/25/99
E-mail: [email]cadpres@spaug.org[/email]
Web Site: [url]http://www.spaug.org[/url]
1. Modified to work with R14 & 2000
2. Now prompts for 3 types of selection sets
3. Works on all types of entities (including LWPOLYLINES)
Large donations to SPAUG is appreciated. :)
------------------------------------------------------------------------
------------------------------------------------------------------------
|;
(defun C:DUPREM ()
(setvar "cmdecho" 0)
(setq F1 NIL
F1 0
)
;; Added by Jeff Tippit 08/25/99
;; Start
(initget "S L A")
(setq SLE
(getkword
"\nSelect objects by (S)election set, (L)imits, or (A)ll: "
)
)
(cond
((= SLE "S") (setq SA (ssget)))
((= SLE "L")
(setq SA (ssget "c" (getvar "extmin") (getvar "extmax")))
)
((= SLE "A")
(setq SA (ssget "X" (list (cons 410 (getvar "CTAB")))))
)
)
;; End
(setq CA 0
TA (sslength SA)
LA NIL
LB NIL
)
(while (< CA TA)
(setq ENTA (ssname SA CA)
EA (cdr (entget ENTA))
TYPA (cdr (assoc 0 EA))
)
;; (if (= typa "POLYLINE") (progn
;; (setq entb (entnext enta) ea (cdr (entget entb)))
;; ))
;; Added by Jeff Tippit 08/25/99
;; Updated for R14 & 2000
;; Start
(setq A1 (assoc 5 EA))
(setq A2 (cons 5 ""))
(setq EA (subst A2 A1 EA))
(if (wcmatch (getvar "ACADVER") "*15*")
(progn
(setq A3 (assoc 330 EA))
(setq A4 (cons 330 ""))
(setq EA (subst A4 A3 EA))
)
)
;; Added by Lucas
(if (= TYPA "VIEWPORT")
(progn
(setq A3 (assoc 69 EA))
(setq A4 (cons 69 ""))
(setq EA (subst A4 A3 EA))
(setq A3 (assoc 68 EA))
(setq A4 (cons 68 ""))
(setq EA (subst A4 A3 EA))
)
)
;; End
(setq LA (cons ENTA LA)
LB (cons EA LB)
CA (+ CA 1)
)
)
(setq SC NIL
SC (ssadd)
LTEST LB
)
(setq CA 0)
(setq TES (car LTEST)
LTEST (cdr LTEST)
TA NIL
TA (length LTEST)
)
(while (/= TA 0)
(if (member TES LTEST)
(progn
(setq SC (ssadd (nth CA LA) SC))
;;(prompt "\nFound aduplicate entity.")
(setq F1 (+ F1 1))
)
)
(setq CA (+ CA 1))
(setq TES (car LTEST)
LTEST (cdr LTEST)
TA (length LTEST)
)
)
(command "_.erase" SC "")
(redraw)
(prompt "\n")
(prin1 F1)
(prompt " duplicate entities erased.")
(princ)
)
(prompt
"\nType DUPREM to run. Delete duplicate entity routine Ver 2.0 loaded."
)
(princ)

;;這是一個刪除完全重疊物件的程序 
;;我也忘了是甚麼時候看到 
;;當時只修改了一些就收起來!! 
 
;| Programmed by Dave Aguilar 
   DUPREM.LSP  1994 Onyx Software 
 
 This program creates an list of entity lists for all entities in the 
 drawing (using the first VERTEX for POLYLINES) and then compares each 
 entity list with the total list, building a new selection set of all 
 duplicate entries which are then erased. 
 
 it's not guarenteed but try it on a copy of a badly duplicated drawing 
 and see if it helps. 
 
------------------------------------------------------------------------ 
------------------------------------------------------------------------ 
 Modified by J. Tippit, SPAUG President                                08/25/99 
    E-mail:                     [email]cadpres@spaug.org[/email] 
    Web Site:                [url]http://www.spaug.org[/url] 
 
        1. Modified to work with R14 & 2000 
        2. Now prompts for 3 types of selection sets 
        3. Works on all types of entities (including LWPOLYLINES) 
 
 Large donations to SPAUG is appreciated. :) 
------------------------------------------------------------------------ 
------------------------------------------------------------------------ 
 
|; 
 
(defun C:DUPREM        () 
  (setvar "cmdecho" 0) 
  (setq        F1 NIL 
        F1 0 
  ) 
  ;; Added by Jeff Tippit 08/25/99 
  ;; Start 
  (initget "S L A") 
  (setq        SLE 
         (getkword 
           "\nSelect objects by (S)election set, (L)imits, or (A)ll: " 
         ) 
  ) 
  (cond 
    ((= SLE "S") (setq SA (ssget))) 
    ((= SLE "L") 
     (setq SA (ssget "c" (getvar "extmin") (getvar "extmax"))) 
    ) 
    ((= SLE "A") 
     (setq SA (ssget "X" (list (cons 410 (getvar "CTAB"))))) 
    ) 
  ) 
  ;; End 
  (setq        CA 0 
        TA (sslength SA) 
        LA NIL 
        LB NIL 
  ) 
  (while (< CA TA) 
    (setq ENTA (ssname SA CA) 
          EA   (cdr (entget ENTA)) 
          TYPA (cdr (assoc 0 EA)) 
    ) 
    ;;      (if (= typa "POLYLINE") (progn 
    ;;         (setq entb (entnext enta) ea (cdr (entget entb))) 
    ;;      )) 
 
    ;; Added by Jeff Tippit 08/25/99 
    ;; Updated for R14 & 2000 
    ;; Start 
    (setq A1 (assoc 5 EA)) 
    (setq A2 (cons 5 "")) 
    (setq EA (subst A2 A1 EA)) 
    (if        (wcmatch (getvar "ACADVER") "*15*") 
      (progn 
        (setq A3 (assoc 330 EA)) 
        (setq A4 (cons 330 "")) 
        (setq EA (subst A4 A3 EA)) 
      ) 
    ) 
    ;; Added by Lucas 
    (if        (= TYPA "VIEWPORT") 
      (progn 
        (setq A3 (assoc 69 EA)) 
        (setq A4 (cons 69 "")) 
        (setq EA (subst A4 A3 EA)) 
        (setq A3 (assoc 68 EA)) 
        (setq A4 (cons 68 "")) 
        (setq EA (subst A4 A3 EA)) 
      ) 
    ) 
    ;; End 
    (setq LA (cons ENTA LA) 
          LB (cons EA LB) 
          CA (+ CA 1) 
    ) 
  ) 
  (setq        SC    NIL 
        SC    (ssadd) 
        LTEST LB 
  ) 
  (setq CA 0) 
  (setq        TES   (car LTEST) 
        LTEST (cdr LTEST) 
        TA    NIL 
        TA    (length LTEST) 
  ) 
  (while (/= TA 0) 
    (if        (member TES LTEST) 
      (progn 
        (setq SC (ssadd (nth CA LA) SC)) 
        ;;(prompt "\nFound aduplicate entity.") 
        (setq F1 (+ F1 1)) 
      ) 
    ) 
    (setq CA (+ CA 1)) 
    (setq TES        (car LTEST) 
          LTEST        (cdr LTEST) 
          TA        (length LTEST) 
    ) 
  ) 
  (command "_.erase" SC "") 
  (redraw) 
  (prompt "\n") 
  (prin1 F1) 
  (prompt " duplicate entities erased.") 
  (princ) 
) 
 
(prompt 
  "\nType DUPREM to run. Delete duplicate entity routine Ver 2.0 loaded." 
) 
(princ)

rainforest · 发表于 2003-2-6 16:54:33

根据本人的需要而修改，喜欢就下吧

tc405003 · 发表于 2006-6-13 01:48:24

是完全重合是有一定误差的

yueye_rui · 发表于 2009-4-23 10:38:29

5楼的好使

cuyongping · 发表于 2013-4-27 13:59:58

谢谢！收藏了！

账号		自动登录	找回密码
密码			立即注册

[LISP程序]：清除重复的实体

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

Re: [LISP程序]：清除重复的实体