删除重叠

KO你 · 发表于 2019-5-13 19:44:40

本帖最后由 KO你于 2019-6-5 02:24 编辑

[code="lisp] (defun C:DUPREM (/ 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选择集类型 [Set/Limits/All] <" :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)
)
[/code]Gu_xl 的源码

以上的源码，不同颜色和不同图层的相同重叠对象不能删除，求大神完善不管什么颜色与图层，相同的重叠对象都可以删除

找到一个完全删除重叠的，不是源码

KO你 · 发表于 2019-5-14 12:26:38

xyp1964  的回帖
(defun c:tt ()
  ;; tt(删除重叠) 忽略图层和颜色
  (setq kw (Ukword 1 "1 2 3" "选择集类型: 1-框选/2-屏幕内/3-全部" kw))
  (cond       ((= kw "1") (setq ss (ssget)))
      ((= kw "2")
      (setq ss (ssget "c" (getvar "extmin") (getvar "extmax")))
      )
      ((= kw "3") (setq ss (ssget "X")))
  )
  (if ss
(progn
   (setq lst       (mapcar       '(lambda (x)
                        (vl-remove-if
                           '(lambda (y) (member (car y) '(-1 5 8 62))) ;8图层62颜色
                           (entget x)
                        )
                     )
                     (xyp-Ss2List ss)
            )
         lst       (xyp-Get-ListSame lst)
   )
   (xyp-erase lst)
)
  )
  (princ)
)
本人没学过编程，只是平时制图需求，拼合大家的源码与想法，院长这个源码是要在ET工具箱才可以用吗，我没装ET工具箱，试过不能运行

KO你 · 发表于 2019-5-14 14:49:27

KO你发表于 2019-5-14 14:46
前面提到忽略颜色与图层，附加上忽略线型

快捷键  eb  删除重叠图块
(defun c:eb (/ ss pt s1 name1 name2 name3 ss1 i)
(setq p1 (getpoint "\n请输入第一角:"))
  (setq p2 (getcorner p1 "\n请输入第二角:"))
  (setq ss (ssget  "w" p1 p2 '((0 . "INSERT")))
i  0
  )
  (while (and ss (setq s1 (ssname ss 0)) (> (sslength ss) 1))
(setq pt  (cdr (assoc 10 (entget s1)))
   name1  (cdr (assoc 2 (entget s1)))
   name2  (cdr (assoc 41 (entget s1)))
   name3  (cdr (assoc 50 (entget s1)))

ss1 (ssget  "w" p1 p2 (list (cons 0 "INSERT") (cons 10 pt)(cons 2 name1)(cons 41 name2)(cons 50 name3)))
)
(if (and ss1 (> (sslength ss1) 1))
   (progn(setq i (+ i (sslength ss1)))
(command "erase" ss1 "")
(entdel s1)
(setq i (- i 1))
(command "select" ss "r" s1 "")
(setq ss (ssget "P"))
   )
   (Progn
(command "select" ss "r" s1 "")
(setq ss (ssget "P"))
   )
)
  )
  (princ "\\n共删除 ")
  (princ i)
  (princ " 个重迭块。 ")
);删除重叠的块

类似删除重叠块一样，忽略颜色，图层，线型，只要是重叠的相同对象都可以删除

satan421 · 发表于 2019-5-14 09:26:49

本帖最后由 satan421 于 2019-5-14 09:30 编辑

;;思路很厉害
;;加上下面几句应该可以
;;但是图层和颜色不一样的要删哪个留哪个，就得你自己写了
      (setq b1 (assoc 62 ea))
      (setq b2 (cons 62 ""))
      (setq ea (subst
               b2
               b1
               ea
               )
      )
      (setq c1 (assoc 8 ea))
      (setq c2 (cons 8 ""))
      (setq ea (subst
               c2
               c1
               ea
               )
      )

664571221 · 发表于 2019-5-14 09:48:43

satan421 发表于 2019-5-14 09:26
;;思路很厉害
;;加上下面几句应该可以
;;但是图层和颜色不一样的要删哪个留哪个，就得你自己写了

能整合一下吗

KO你 · 发表于 2019-5-14 11:58:49

satan421 发表于 2019-5-14 09:26
;;思路很厉害
;;加上下面几句应该可以
;;但是图层和颜色不一样的要删哪个留哪个，就得你自己写了

删置底的，留置顶的，帮忙整核一下咯

satan421 · 发表于 2019-5-14 13:35:11

KO你发表于 2019-5-14 12:26
xyp1964 的回帖
(defun c:tt ()
;; tt(删除重叠) 忽略图层和颜色

;;你需要加载他的函数库，需要用几个子函数:
;;xyp-Ss2List xyp-Get-ListSame xyp-erase

satan421 · 发表于 2019-5-14 13:53:48

KO你发表于 2019-5-14 11:58
删置底的，留置顶的，帮忙整核一下咯

lisp应该是没办法判断图元的显示顺序的(也可能可以，但我不知道)
如果没有人为的调整过图元显示顺序，倒是可以判断生成的先后顺序，删除后生成或者先生成的图元

KO你 · 发表于 2019-5-14 14:46:25

KO你发表于 2019-5-14 12:26
xyp1964 的回帖
(defun c:tt ()
;; tt(删除重叠) 忽略图层和颜色

前面提到忽略颜色与图层，附加上忽略线型

KO你 · 发表于 2019-5-14 14:51:48

KO你发表于 2019-5-14 14:49
快捷键 eb 删除重叠图块
(defun c:eb (/ ss pt s1 name1 name2 name3 ss1 i)
(setq p1 (getpoint "\n ...

在明经论坛是可以找到删除重叠图块和删除重叠文字，以制图的经验还是想整理一个删除所有重叠对象的程序出来最完善

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

[源码] 删除重叠

本帖子中包含更多资源