删除重叠
本帖最后由 KO你 于 2019-6-5 02:24 编辑(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选择集类型 <" :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)
)
Gu_xl 的源码
以上的源码，不同颜色和不同图层的相同重叠对象不能删除，求大神完善不管什么颜色与图层，相同的重叠对象都可以删除
找到一个完全删除重叠的，不是源码
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: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")))
i0
)
(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: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
)
)
satan421 发表于 2019-5-14 09:26
;;思路很厉害
;;加上下面几句应该可以
;;但是图层和颜色不一样的要删哪个留哪个，就得你自己写了
能整合一下吗 satan421 发表于 2019-5-14 09:26
;;思路很厉害
;;加上下面几句应该可以
;;但是图层和颜色不一样的要删哪个留哪个，就得你自己写了
删置底的，留置顶的，帮忙整核一下咯 KO你 发表于 2019-5-14 12:26
xyp1964的回帖
(defun c:tt ()
;; tt(删除重叠) 忽略图层和颜色
;;你需要加载他的函数库，需要用几个子函数:
;;xyp-Ss2List xyp-Get-ListSame xyp-erase KO你 发表于 2019-5-14 11:58
删置底的，留置顶的，帮忙整核一下咯
lisp应该是没办法判断图元的显示顺序的(也可能可以，但我不知道)
如果没有人为的调整过图元显示顺序，倒是可以判断生成的先后顺序，删除后生成或者先生成的图元
KO你 发表于 2019-5-14 12:26
xyp1964的回帖
(defun c:tt ()
;; tt(删除重叠) 忽略图层和颜色
前面提到忽略颜色与图层，附加上忽略线型 KO你 发表于 2019-5-14 14:49
快捷键eb删除重叠图块
(defun c:eb (/ ss pt s1 name1 name2 name3 ss1 i)
(setq p1 (getpoint "\n ...
在明经论坛是可以找到删除重叠图块和删除重叠文字，以制图的经验还是想整理一个删除所有重叠对象的程序出来最完善
页:
[1]
2