[求助]请教高手！！另类删重复图元LISP!!!

jbaobao · 发表于 2006-3-15 12:56:00

请教：在论坛上有很多删重复图元的LISP我试了都有如下问题：在一条线上如有重复一条和它不一样长的线时不能删除此重复线！！！请教有办法解决吗？？（但是要求不能把不在同一个图层的图元删除！））））

谢谢了！！！！！

lee50310 · 发表于 2020-2-18 23:41:12

本帖最后由 lee50310 于 2020-2-18 23:59 编辑

來源位置:https://forum.bricsys.com/discussion/33192/overkill-in-lisp-routine
試試這段代碼, 可完全删除重叠图元

;;圈选范围,删除重叠图元
;;
(defun c:Test (/ ss item)
(if (setq ss (ssget))
(progn
(command "-overkill" ss "" "Ignore" "lweight" "Ignore" "Layer" "")
(foreach item (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(if (not (entget item))
(setq ss (ssdel item ss))
)
)
)
)
(princ)
)

KO你 · 发表于 2019-12-27 05:03:31

尘缘一生发表于 2019-12-27 00:29
delCircleArc

Li_item

这个删除重叠图元scty基本已经有全部重叠对象删除功能
http://bbs.mjtd.com/plugin.php?i ... yNjY2NnwxNzk1Mzg%3D

尘缘一生 · 发表于 2019-12-27 00:29:37

自贡黄明儒发表于 2013-5-19 08:42
这个是我的overkill之路上自己写的东西

delCircleArc

Li_item

ArcJoin

能补上这三个函数吗？

citykunan · 发表于 2006-3-15 15:00:00

用express tools 中的overkill

xbsteel · 发表于 2006-3-15 15:41:00

试试这个

;;;图元合并
(defun c:tyhb (/ ARC_LIST ENT I LINE_LIST SS)
(while (and
 (setq ss (ssget (list (cons -4 "<or")
 (cons 0 "arc")
 (cons 0 "CIRCLE")
 (cons 0 "line")
 (cons -4 "or>")
 )
 )
 )
 (> (sslength ss) 0)
)
 (hbzhx ss)
 )
(princ)
)
(defun cs_pross (to i / CS_TEXT MYI)
(setq cs_text ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>")
(setq myi (fix (/ (* (strlen cs_text) i) to))
cs_text (substr cs_text 1 myi)
)
(grtext -2 cs_text)
)

(defun hbzhx ( ss / ARC_LIST ENT I LINE_LIST SS jd)
;;; 转为数据表
 (grtext -2 "正在整理数据")
 (setq i 0 jd 1e-5
 line_list ' ()
 arc_list '()
 )
 (repeat (sslength ss)
 (setq ent (ssname ss i)
 i (1+ i)
 )
 (if (= "LINE" (cdr (assoc 0 (entget ent))))
(setq line_list (cons (line_data ent) line_list))
(setq arc_list (cons (arc_data ent) arc_list))
)
 )
 (setq line_list (vl-sort line_list
 '(lambda (e1 e2)
 (if (equal (car e1) (car e2) jd)
 (if (equal (cadr e1) (cadr e2) jd)
 (if (equal (car (caddr e1)) (car (caddr e2)) jd)
 (< (cadr (caddr e1)) (cadr (caddr e2)))
 (< (car (caddr e1)) (car (caddr e2)))
 )
 (< (cadr e1) (cadr e2))
 )
 (< (car e1) (car e2))
 )
 )
 )
 )
 (setq arc_list (vl-sort arc_list
 '(lambda (e1 e2)
 (if (equal (car e1) (car e2) jd)
 (if (equal (cadr e1) (cadr e2) jd)
 (if (equal (caddr e1) (caddr e2) jd)
 (< (cadddr e1) (cadddr e2))
 (< (caddr e1) (caddr e2))
 )
 (< (cadr e1) (cadr e2))
 )
 (< (car e1) (car e2))
 )
 )
 )
 )
 (if line_list (hb_line line_list jd))
 (if arc_list (hb_arc arc_list jd))
 (grtext)
(princ)
)
(defun hb_line (line_list jd / B BIAOJI DATA ENT K LINE_A LINE_B P1 P2 P3 P4 P5 JD XUHAO ZONGSHU i lay)
(setq zongshu (length line_list)
i 0
xuhao 0)
(princ (strcat "\n共处理" (rtos zongshu) "个实体"))
(grtext -1 "合并直线")
(while (> (length line_list) 0)
 (setq xuhao (1+ xuhao))
 (cs_pross zongshu xuhao)
 (setq line_a (car line_list)
 line_list (cdr line_list)
 biaoji t
 k (car line_a)
 b (cadr line_a)
 p1 (caddr line_a)
 p2 (cadddr line_a)
 ent (last line_a)
 lay (cdr (assoc 8 (entget ent)))
 )
 (while (and biaoji
 (> (length line_list) 0)
 )
 (setq line_b (car line_list)
 )
 (cond
((and (equal k (car line_b) jd)
 (equal b (cadr line_b) jd)
 (= lay (cdr (assoc 8 (entget (last line_b)))))
 )
(setq p3 (caddr line_b)
 p4 (cadddr line_b)
 p5 (vl-sort (list p1 p2 p3 p4)
 '(lambda (e1 e2)
 (if (equal (car e1) (car e2) jd)
 (< (cadr e1) (cadr e2))
 (< (car e1) (car e2))
 )
 )
 )
 p4 (cadr p5)
)
(if (or (equal p1 p4 jd)
 (equal p3 p4 jd)
 )
 (progn
 (setq p1 (car p5)
 p2 (last p5)
 line_list (cdr line_list)
 )
 (entdel (last line_b))
 (setq xuhao (1+ xuhao))
 (cs_pross zongshu xuhao)
 (setq i (1+ i))
 )
 (setq biaoji nil)
)
)
(t (setq biaoji nil))
)
 )
 (setq data (entget ent)
 data (subst (cons 10 p1) (assoc 10 data) data)
 data (subst (cons 11 p2) (assoc 11 data) data)
 )
 (entmod data)
 )
(princ (strcat "，删除了" (rtos i) "个实体"))
(princ)
)
(defun hb_arc (arc_list jd / i ARC_A ARC_B BIAOJI BJ DATA EANGL EANGL1 ENT JD LINE_LIST P5 PC SANGL SANGL1 XUHAO ZONGSHU lay)
(setq zongshu (length arc_list)
xuhao 0
i 0)
(princ (strcat "\n共处理" (rtos zongshu) "个实体"))
(grtext -1 "合并圆弧")
(while (> (length arc_list) 0)
 (setq xuhao (1+ xuhao))
 (cs_pross zongshu xuhao)
 (setq arc_a (car arc_list)
 arc_list (cdr arc_list)
 biaoji t
 bj (car arc_a)
 pc (list (cadr arc_a) (caddr arc_a))
 sangl (cadddr arc_a)
 eangl (nth 4 arc_a)
 ent (last arc_a)
 lay (cdr (assoc 8 (entget ent)))
 )
 (while (and biaoji
 (> (length arc_list) 0)
 )
 (setq arc_b (car arc_list)
 )
 (cond
((and (equal bj (car arc_b) jd)
 (equal pc (list (cadr arc_b) (caddr arc_b)) jd)
 (= lay (cdr (assoc 8 (entget (last arc_b)))))
)
(setq sangl1 (cadddr arc_b)
 eangl1 (nth 4 arc_b)
 p5 (vl-sort (list sangl eangl sangl1 eangl1)
 '(lambda (e1 e2)
 (< e1 e2)
 )
 )
 sangl1 (nth (- (length p5) 2) p5)
)
(if (or (equal eangl sangl1 jd)
 (equal eangl1 sangl1 jd)
 )
 (progn
 (setq sangl (car p5)
 eangl (last p5)
 arc_list (cdr arc_list)
 )
 (entdel (last arc_b))
 (setq xuhao (1+ xuhao))
 (cs_pross zongshu xuhao)
 (setq i (1+ i))
 )
 (setq biaoji nil)
)
)
(t (setq biaoji nil))
 )
 )
 (setq data (entget ent)
 data (subst (cons 50 sangl) (assoc 50 data) data)
 data (subst (cons 51 eangl) (assoc 51 data) data)
 )
 (entmod data)
 )
(princ (strcat "，删除了" (rtos i) "个实体"))
(princ)
)
(defun arc_data (ent / BJ DATA EANGL PC SANGL)
(setq data (entget ent))
(setq bj (cdr (assoc 40 data)))
(setq pc (cdr (assoc 10 data)))
(setq sangl (cdr (assoc 50 data)))
(setq eangl (cdr (assoc 51 data)))
(if (not sangl)
 (setq sangl 0.0
 eangl (+ pi pi)
 )
)
(if (< eangl sangl)
 (setq eangl (+ eangl (+ pi pi)))
)
(list bj (car pc) (cadr pc) sangl eangl ent)
)

(defun line_data (ent / B K P1 P2 jd)
 (setq p1 (vlax-curve-getstartpoint ent)
 p2 (vlax-curve-getendpoint ent)
 jd 1e-5
 )
 (if (equal (car p1) (car p2) jd)
 (setq k nil
 b (car p1)
 )
 (setq k (/ (- (cadr p2) (cadr p1))
 (- (car p2) (car p1))
 )
 b (- (cadr p1) (* (car p1) k))
 )
 )
 (setq p2 (vl-sort (list p1 p2)
 '(lambda (e1 e2)
 (if (equal (car e1) (car e2) jd)
 (< (cadr e1) (cadr e2))
 (< (car e1) (car e2))
 )
 )
 )
 p1 (car p2)
 p2 (cadr p2)
 )
 (list k
 b
 (list (car p1) (cadr p1))
 (list (car p2) (cadr p2))
 ent
 )
)

jdhszh · 发表于 2006-3-15 17:49:00

三楼的好酷，我要试一下。顶！

jbaobao · 发表于 2006-3-15 18:01:00

太好了，谢谢你了！！！

lifesun · 发表于 2006-5-15 19:38:00

楼主辛苦啦,我先试试看好用不,谢谢你了

hanhang200 · 发表于 2006-5-16 15:25:00

那么长，工也试一下,

真的不错唉

SHOUXI · 发表于 2013-5-19 08:15:08

非多义线的同一图层重复图元能删除，一直想找个能取代OVERKILL的类似外挂！

自贡黄明儒 · 发表于 2013-5-19 08:39:44

其实本论坛上早就有了(谁写的忘了),写得很经典,从中我看到的是智慧
我回复在晓东论坛上,晓东马上加分了,老大就是老大,慧眼识珠.

;;8 删除重叠多段线、线、弧、块、文字
(DEFUN HH:delBLOCKs (ss / E EN K LIST1 S9 XY)
(repeat (setq k (sslength ss))
(spin "重叠对象")
(if (and (setq e (ssname ss (setq k (1- k))))
(setq en (entget e))
)
(progn
(setq xy (cdr en))
(IF (SETQ S9 (ASSOC 5 XY))
(SETQ XY (subst '(5 . "ASD") S9 XY))
)
(if (member xy list1)
(entdel e)
(setq list1 (cons xy list1))
)
)
)
)
)

自贡黄明儒 · 发表于 2013-5-19 08:42:27

这个是我的overkill之路上自己写的东西

;;5.2 先删除与圆同心的圆和圆弧,然后同心同半径圆弧合并
;;(setq ss (ssget "X" '((0 . "ARC"))))
(defun del-Circles
(ss ssCircle / CEN E E1 E2 EN EN1 EN2 I N N1 R SS SSARC)
(delCircleArc ssCircle) ;删除与圆同心的圆和圆弧
(if ss
(repeat (setq n (sslength ss))
(spin "合并圆弧")
(if (and (setq e (ssname ss (setq n (1- n))))
(setq en (entget e))
)
(progn
(setq Cen (Li_item 10 en))
(setq R (Li_item 40 en))
(setq ssArc (ssget "x"
(list (cons 0 "ARC")
(cons 10 Cen)
(cons 40 R)
)
)
)
(repeat (setq n1 (sslength ssArc))
(if (and (setq e1 (ssname ssArc (setq n1 (1- n1))))
(setq en1 (entget e1))
)
(progn
(setq i n1)
(while (and (> i 0) ssArc)
(if (and (setq e2 (ssname ssArc (setq i (1- i))))
(setq en2 (entget e2))
)
(ArcJoin e1 e2 ssArc)
)
)
)
)
)
)
)
)
)
(princ)
)

;;5.2  先删除与圆同心的圆和圆弧,然后同心同半径圆弧合并 
  ;;(setq ss (ssget "X" '((0 . "ARC")))) 
  (defun del-Circles 
         (ss ssCircle / CEN E E1 E2 EN EN1 EN2 I N N1 R SS SSARC) 
    (delCircleArc ssCircle)                ;删除与圆同心的圆和圆弧 
    (if        ss 
      (repeat (setq n (sslength ss)) 
        (spin "合并圆弧") 
        (if (and (setq e (ssname ss (setq n (1- n)))) 
                 (setq en (entget e)) 
            ) 
          (progn 
            (setq Cen (Li_item 10 en)) 
            (setq R (Li_item 40 en)) 
            (setq ssArc        (ssget "x" 
                               (list (cons 0 "ARC") 
                                     (cons 10 Cen) 
                                     (cons 40 R) 
                               ) 
                        ) 
            ) 
            (repeat (setq n1 (sslength ssArc)) 
              (if (and (setq e1 (ssname ssArc (setq n1 (1- n1)))) 
                       (setq en1 (entget e1)) 
                  ) 
                (progn 
                  (setq i n1) 
                  (while (and (> i 0) ssArc) 
                    (if        (and (setq e2 (ssname ssArc (setq i (1- i)))) 
                             (setq en2 (entget e2)) 
                        ) 
                      (ArcJoin e1 e2 ssArc) 
                    ) 
                  ) 
                ) 
              ) 
            ) 
          ) 
        ) 
      ) 
    ) 
    (princ) 
  )

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

[求助]请教高手！！另类删重复图元LISP!!!

点评

点评

浏览过的版块