删除重复块高程--修改明经某位大侠程序
;选择集与对象名表互转
(defun cx-ss2en
(ss / enlst)
(cond
((= (type ss) 'PICKSET)
(vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
)
((= (type ss) 'LIST)
(setq enlst (ssadd))
(last (mapcar '(lambda (x) (ssadd x enlst)) ss))
)
((='ename(type ss))
(ssadd ss)
)
)
)
;货物分两组（样品 库存）
(defun lst->2lst(lst / lst1 lst2)
(setq lst1 '() lst2 '())
(foreach a lst
(if (member a lst2)
(setq lst1 (cons a lst1))
(setq lst2 (cons a lst2))
)
)
(cons (reverse lst2) (reverse lst1))
)
;检查重叠块
(defun c:chk_blocks (/ ss pt s1 dxf2 dxf41 dxf50 ss1 i)
(setq ss (ssget '((0 . "insert")))
i0
)
(if (and ss (> (sslength ss) 2))
(progn
(setq entlst (cx-ss2en ss)
ptlst (mapcar '(lambda(x) (assoc 10(entget x))) entlst)
2ptlst (lst->2lst ptlst)
)
(if (cdr 2ptlst)
(progn
;(setq pt (getpoint "引出点："))
(foreach x (cdr 2ptlst)
;(entmake (list '(0 . "line") '(8 . "0-辅助层tem") (cons 62 1) x (cons 11 pt)))
(repeat (setq k (length (cdr 2ptlst)))
(if(and (setq e (ssname ss (setq k (1- k ))))
(setq en (entget e))
)
(progn
(if (member x en)
(entdel e)
;(setq en (cons x en))
)
)
)
)
)
)
(alert "报告老大，没有找到重叠块！")
)
)
(alert "老大，这么简单的问题自己解决！")
)
(princ)
)
;;156.1 [功能] 删除重叠对象(overkill)
;;不知谁写的,太好了.
(DEFUN HH:delBLOCKs (ss / E EN K LIST1 S9 XY)
(repeat (setq k (sslength ss))
(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))
)
)
)
)
) 还是写明出处与作者比较好
部分应是来之于77077
http://bbs.mjtd.com/thread-113683-1-1.html
HH开头的函数应该是黄老的
页:
[1]