求助：修改删除重复图元程序，改成默认框选

andyzha

Gu_xl 的源码，简洁实用，能删除图纸中的重叠图元，只是需要每次都选择Set/Limits/All，想修改成不用选择，直接运行程序就是框选清理，求修改。

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

(defun C:TT (/ F1 SLE SA CA TA LA LB ENTA EA TYPA A1 A2 A3 A4 SC LTEST<br />                    TES<br />                 )<br />   (setq F1 NIL<br />         F1 0<br />   )<br />   (or<br />     :GCHOICE<br />     (setq :GCHOICE "Set")<br />   )<br />   (initget "Set Limits All")<br />   (setq SLE (getkword (strcat "\n选择集类型 [Set/Limits/All] <" :GCHOICE<br />                               ">: "<br />                       )<br />             )<br />   )<br />   (if (not SLE)<br />     (setq SLE :GCHOICE)<br />     (setq :GCHOICE SLE)<br />   )<br />   (cond<br />     ((= SLE "Set")<br />       (setq SA (ssget))<br />     )<br />     ((= SLE "Limits")<br />       (setq SA (ssget "c" (getvar "extmin") (getvar "extmax")))<br />     )<br />     ((= SLE "All")<br />       (setq SA (ssget "X"))<br />     )<br />   )<br />   (if (and<br />         SA<br />         (= (type SA) 'PICKSET)<br />         (not (zerop (sslength SA)))<br />       )<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<br />                    A2<br />                    A1<br />                    EA<br />                  )<br />         )<br />         (if (wcmatch (getvar "ACADVER") "*15*")<br />           (progn<br />             (setq A3 (assoc 330 EA))<br />             (setq A4 (cons 330 ""))<br />             (setq EA (subst<br />                        A4<br />                        A3<br />                        EA<br />                      )<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 /> )

xj6019

(defun C:TT (/ F1 SLE SA CA TA LA LB ENTA EA TYPA A1 A2 A3 A4 SC LTEST   TES)
  (setq F1 NIL
                F1 0
  )
  (if (and
                                (setq SA (ssget))
        (= (type SA) 'PICKSET)
        (not (zerop (sslength SA)))
      )
    (progn
      (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))
        )
        (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
                     )
            )
          )
        )
        (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))
            (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 " 个物体被删除.")
    )
  )
  (princ)
)

hhh454

1. ;;只能删除重合一起的属性相同的图元，长度不一样的线，重合在一起是删除不了的

复制代码

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

(defun C:TT (/ F1 SLE SA CA TA LA LB ENTA EA TYPA A1 A2 A3 A4 SC LTEST<br />                    TES<br />                 )<br />   (setq F1 NIL<br />         F1 0<br />   )<br /> <br />   (setq SA (ssget))<br /> <br />   (if (and<br />         SA<br />         (= (type SA) 'PICKSET)<br />         (not (zerop (sslength SA)))<br />       )<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<br />                    A2<br />                    A1<br />                    EA<br />                  )<br />         )<br />         (if (wcmatch (getvar "ACADVER") "*15*")<br />           (progn<br />             (setq A3 (assoc 330 EA))<br />             (setq A4 (cons 330 ""))<br />             (setq EA (subst<br />                        A4<br />                        A3<br />                        EA<br />                      )<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 /> )

andyzha

hhh454 发表于 2022-8-19 18:33

能删除重合在一起的图元就可以，测试过了，只有重合且属性完全相同的才删除，这就足够用了。

loveu515

hhh454 发表于 2022-8-19 18:33

这个程序很实用，您能帮忙改一下吗？把重合一起的属性相同的图元（原图元和重合图元全部删除），只留下属性不同的图元。这个想法好实现吗？