请教能否编一个像ET中OVERKILL命令一样lisp,删除的图中有一些重叠的圆和文字?

cxs259

请教能否编一个像ET中OVERKILL命令一样lisp,删除的图中有一些重叠的圆和文字

ljttjl

http://ljttjl.ys168.com/   2009-2试用程序及演示   20091111删除完全重叠图元对象程序
以下为此程序演示：

尘缘一生

Gu_xl 发表于 2011-8-3 13:09
回复 cxs259 的帖子

楼上的都别废话，用这个吧！

这个程序算最好了目前，就是偶尔有几根不该删的线，删除了，不知道原因，还有，不知道重复文字能否删除。

zhb236623

如果有三根线，能不能把重复的三根一起删除 了。只要两个物体重复，直接全部删除呢。

Gu_xl

回复 cxs259 的帖子

楼上的都别废话，用这个吧！

1. (defun C:DUPREM (/ F1 SLE SA CA TA LA LB ENTA EA TYPA A1 A2 A3 A4 SC
   
2.    LTEST TES
   
3.   )
   
4.   (setq F1 NIL
   
5. F1 0
   
6.   )
   
7.   (or :GCHOICE (setq :GCHOICE "Set"))
   
8.   (initget "Set Limits All")
   
9.   (setq SLE
   
10.   (getkword (strcat "\n选择集类型 [Set/Limits/All] <"
    
11.       :GCHOICE
    
12.       ">: "
    
13.      )
    
14.   )
    
15.   )
    
16.   (if (not SLE)
    
17.     (setq SLE :GCHOICE)
    
18.     (setq :GCHOICE SLE)
    
19.   )
    
20.   (cond
    
21.     ((= SLE "Set") (setq SA (ssget)))
    
22.     ((= SLE "Limits")
    
23.      (setq SA (ssget "c" (getvar "extmin") (getvar "extmax")))
    
24.     )
    
25.     ((= SLE "All") (setq SA (ssget "X")))
    
26.   )
    
27. 
    
28.   (if (and SA (= (type SA) 'PICKSET) (not (zerop (sslength SA))))
    
29.     (progn
    
30.       (setq CA 0
    
31.      TA (sslength SA)
    
32.      LA NIL
    
33.      LB NIL
    
34.       )
    
35.       (while (< CA TA)
    
36. (setq ENTA (ssname SA CA)
    
37.        EA   (cdr (entget ENTA))
    
38.        TYPA (cdr (assoc 0 EA))
    
39. )
    
40. (setq A1 (assoc 5 EA))
    
41. (setq A2 (cons 5 ""))
    
42. (setq EA (subst A2 A1 EA))
    
43. (if (wcmatch (getvar "ACADVER") "*15*")
    
44.    (progn
    
45.      (setq A3 (assoc 330 EA))
    
46.      (setq A4 (cons 330 ""))
    
47.      (setq EA (subst A4 A3 EA))
    
48.    )
    
49. )
    
50. 
    
51. (setq LA (cons ENTA LA)
    
52.        LB (cons EA LB)
    
53.        CA (+ CA 1)
    
54. )
    
55.       )
    
56.       (setq SC   NIL
    
57.      SC   (ssadd)
    
58.      LTEST LB
    
59.       )
    
60.       (setq CA 0)
    
61.       (setq TES   (car LTEST)
    
62.      LTEST (cdr LTEST)
    
63.      TA   NIL
    
64.      TA   (length LTEST)
    
65.       )
    
66.       (while (/= TA 0)
    
67. (if (member TES LTEST)
    
68.    (progn
    
69.      (setq SC (ssadd (nth CA LA) SC))
    
70.      (setq F1 (+ F1 1))
    
71.    )
    
72. )
    
73. (setq CA (+ CA 1))
    
74. (setq TES   (car LTEST)
    
75.        LTEST (cdr LTEST)
    
76.        TA    (length LTEST)
    
77. )
    
78.       )
    
79.       (command "erase" SC "")
    
80.       (redraw)
    
81.       (prompt "\n")
    
82.       (prin1 F1)
    
83.       (prompt " 个物体被删除.")
    
84.     )
    
85.   )
    
86.   (princ)
    
87. )
    

(defun C:DUPREM (/ F1 SLE SA CA TA LA LB ENTA EA TYPA A1 A2 A3 A4 SC<br />    LTEST TES<br />   )<br />   (setq F1 NIL<br /> F1 0<br />   )<br />   (or :GCHOICE (setq :GCHOICE "Set"))<br />   (initget "Set Limits All")<br />   (setq SLE<br />   (getkword (strcat "\n选择集类型 [Set/Limits/All] <"<br />       :GCHOICE<br />       ">: "<br />      )<br />   )<br />   )<br />   (if (not SLE)<br />     (setq SLE :GCHOICE)<br />     (setq :GCHOICE SLE)<br />   )<br />   (cond<br />     ((= SLE "Set") (setq SA (ssget)))<br />     ((= SLE "Limits")<br />      (setq SA (ssget "c" (getvar "extmin") (getvar "extmax")))<br />     )<br />     ((= SLE "All") (setq SA (ssget "X")))<br />   )<br /> <br />   (if (and SA (= (type SA) 'PICKSET) (not (zerop (sslength SA))))<br />     (progn<br />       (setq CA 0<br />      TA (sslength SA)<br />      LA NIL<br />      LB NIL<br />       )<br />       (while (< CA TA)<br /> (setq ENTA (ssname SA CA)<br />        EA   (cdr (entget ENTA))<br />        TYPA (cdr (assoc 0 EA))<br /> )<br /> (setq A1 (assoc 5 EA))<br /> (setq A2 (cons 5 ""))<br /> (setq EA (subst A2 A1 EA))<br /> (if (wcmatch (getvar "ACADVER") "*15*")<br />    (progn<br />      (setq A3 (assoc 330 EA))<br />      (setq A4 (cons 330 ""))<br />      (setq EA (subst A4 A3 EA))<br />    )<br /> )<br /> <br /> (setq LA (cons ENTA LA)<br />        LB (cons EA LB)<br />        CA (+ CA 1)<br /> )<br />       )<br />       (setq SC   NIL<br />      SC   (ssadd)<br />      LTEST LB<br />       )<br />       (setq CA 0)<br />       (setq TES   (car LTEST)<br />      LTEST (cdr LTEST)<br />      TA   NIL<br />      TA   (length LTEST)<br />       )<br />       (while (/= TA 0)<br /> (if (member TES LTEST)<br />    (progn<br />      (setq SC (ssadd (nth CA LA) SC))<br />      (setq F1 (+ F1 1))<br />    )<br /> )<br /> (setq CA (+ CA 1))<br /> (setq TES   (car LTEST)<br />        LTEST (cdr LTEST)<br />        TA    (length LTEST)<br /> )<br />       )<br />       (command "erase" SC "")<br />       (redraw)<br />       (prompt "\n")<br />       (prin1 F1)<br />       (prompt " 个物体被删除.")<br />     )<br />   )<br />   (princ)<br /> )<br />

mandala

虽然我不喜欢ljttjl，但觉得应该为其辩护。

将自己的劳动成果开源共享，这是种高尚的行为；将其用来卖钱，则属于理所应当。请注意：没能做到“高尚”，并不属于“卑劣”。就像你无权要求微软白送你windows7。

这就是“good”（道德）和“right”（权利）的区别。

当然，做“高尚”的行为，会感到很爽，这也属于一种“得利”，只是各人对这种得利的感觉不尽相同。

顺便学习一下gu_xl版主的源代码，他无疑属于“高尚”。

xzqk132

同意楼上的观点，开源肯定是造福大家，但是用自己的劳动成果来获利，也属正常的行为。
支持Gu_xl版主一直以来的奉献！

cxs259

谢谢G版的无私奉献，还有一个问题能否在此一同给予解答，如附图若采用您所编bianjie命令后，整个图形会消失，是什么原因？

andyding

这么麻烦，到ET的资料夹里找到源码，改个简单的命令名，重新编译一下不就行了，费这么大事。我确认里面有源码，我自己就是这么干的。

doro

这个比较厉害

zdqwy19

互联网的大爷，我等待30分钟才连上网