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

andyzha 发表于 2022-8-19 17:02:58

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

(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
)
(or
:GCHOICE
(setq :GCHOICE "Set")
)
(initget "Set Limits All")
(setq SLE (getkword (strcat "\n选择集类型 <" :GCHOICE
                           ">: "
                  )
         )
)
(if (not SLE)
(setq SLE :GCHOICE)
(setq :GCHOICE SLE)
)
(cond
((= SLE "Set")
   (setq SA (ssget))
)
((= SLE "Limits")
   (setq SA (ssget "c" (getvar "extmin") (getvar "extmax")))
)
((= SLE "All")
   (setq SA (ssget "X"))
)
)
(if (and
   SA
   (= (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)
)

xj6019 发表于 2022-8-19 17:56:06

(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 发表于 2022-8-19 18:33:19

本帖最后由 hhh454 于 2022-8-19 18:36 编辑

;;只能删除重合一起的属性相同的图元，长度不一样的线，重合在一起是删除不了的
(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
)

(setq SA (ssget))

(if (and
   SA
   (= (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)
)

andyzha 发表于 2022-8-19 18:47:20

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

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

loveu515 发表于 2023-6-26 17:56:01

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

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

页: [1]

明经CAD社区's Archiver

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