删除完全重复的多段线
(defun vxs (e / i v lst)(setq i 0)
(while
(setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
(setq lst (cons v lst))
)
(reverse lst))
;选择集与对象名表互转
(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_poly (/ ss pt s1 dxf2 dxf41 dxf50 ss1 i)
(setq ss (ssget '((0 . "*polyline")))
i0
)
(if (and ss (> (sslength ss) 2))
(progn
(setq entlst (cx-ss2en ss)
ptlst (mapcar '(lambda(x) (vxs 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 (equal x (vxs e))
(entdel e)
;(setq en (cons x en))
)
)
)
)
)
)
(alert "报告老大，没有找到重叠块！")
)
)
(alert "老大，这么简单的问题自己解决！")
)
(princ)
) 不错，很有实用价值 楼主你也是做测量的吗? 73哥函数 删除完全重复多段线 包括重复但起点或终点不同 或者方向不同 但投影重复
(defun Plinexy(e / p a b n ob q et d d1 en et) ;;多线段节点坐标(滤掉了多余点，未处理假闭合)
(setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)
(cond((="LWPOLYLINE"et)
(repeat(length a)(setq b (nth n a) n (+ n 1))
(if (= 10 (car b))(progn
(setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))
(if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
(setq p (list q))))
)))
((="POLYLINE"et)
(SETQ EN (ENTGET (SETQ E (ENTNEXT E))))
(WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")
(SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))
(if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
(setq p (list q)))
(SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))
(setq p(reverse p))
))
P)
;@起点或者方向不同的两个多边形，CAD不会认为它们相同，但是用数学上集合的概念来对待它们的顶点表就好了
(defun remove(l e fun)(vl-remove'nil(mapcar'(lambda(x)(if(not(equal x e fun))x))l)))
(defun lst-(l1 l2 fun)(foreach x l2(setq l1(remove l1 x fun)))l1)
;用lst-求两个多边形顶点坐标表的差集，如果为nil那么这两个多边形它们是相同的，不管它们起点以及方向是否相同
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(lst- (plinexy pzx) (plinexy lll) 1)
;令: (plinexy pzx)
;((138.117 32.0953) (159.105 69.993) (130.531 80.3517) (115.359 48.7703))
;命令: (plinexy opo)
;((130.531 80.3517) (115.359 48.7703) (138.117 32.0953) (159.105 69.993))
(defun vxs (e / i v lst)
(setq i 0)
(while
(setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
(setq lst (cons v lst))
)
(reverse lst))
;选择集与对象名表互转
(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 (or (member a lst2) (vl-some'(lambda(x)(not(lst- a x 0))) lst2))
(setq lst1 (cons a lst1))
(setq lst2 (cons a lst2))
)
)
(cons (reverse lst2) (reverse lst1))
)
;检查重叠块
(defun c:chk_poly (/ ss pt s1 dxf2 dxf41 dxf50 ss1 i)
(setq ss (ssget '((0 . "*polyline")))
i0
)
(if (and ss (> (sslength ss) 2))
(progn
(setq entlst (cx-ss2en ss)
ptlst (mapcar '(lambda(x) (Plinexy 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 (equal x (Plinexy e))
(entdel e)
;(setq en (cons x en))
)
)
)
)
)
)
(alert "报告老大，没有找到重叠块！")
)
)
(alert "老大，这么简单的问题自己解决！")
)
(princ)
) 厉害~~~~~~~~~~~~~~~~~~~ 树櫴希德 发表于 2016-9-13 20:38
73哥函数 删除完全重复多段线 包括重复但起点或终点不同 或者方向不同 但投影重复
次代码不能成功，希望完善 (defun tt(e pts p a)
(setq pts(vl-sort(mapcar'(lambda(x)(vlax-curve-getDistAtpoint e(vlax-curve-getclosestpointto e x)))pts)'<))
(vl-every'(lambda(x y)(entmakex(mapcar'cons'(0 10 11)(list"line"x y))))
(setq pts(mapcar'(lambda(x)(polar p a x))pts))(cdr pts))
)
(defun c:tt(/ e p p1 pts)
(setq e(car(entsel"选择曲线")))
(while(setq p(getpoint))(setq pts(cons p pts)))
(and(setq p(getpoint"起点"))
(setq a(getangle p"方向"))
(tt e pts p a)))
；；73哥函数 曲线投影到直线 【活跃】江南十笑(2509817695) 2020/10/14 9:46:41
嗯就相当于一条绳子这些点是绳结 现在绳子是圆弧要把绳子拉直
【活跃】江南十笑(2509817695) 2020/10/14 9:47:08
水平方向 就行了 平行X轴
(defun vxs (e / i v lst)
(setq i 0)
(while
(setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
(setq lst (cons v lst))
)
(reverse lst))
;选择集与对象名表互转
(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_poly (/ ss pt s1 dxf2 dxf41 dxf50 ss1 i)
(setq ss (ssget '((0 . "*polyline")))
i0
)
(if (and ss (> (sslength ss) 2))
(progn
(setq entlst (cx-ss2en ss)
ptlst (mapcar '(lambda(x) (vxs 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 (equal x (vxs e))
(entdel e)
;(setq en (cons x en))
)
)
)
)
)
)
(alert "报告老大，没有找到重叠块！")
)
)
(alert "老大，这么简单的问题自己解决！")
)
(princ)
)
赞一个。。。。 非常不错的代码，谢谢楼主分享 本帖最后由 skg123 于 2021-5-29 00:21 编辑
测试了一下，1楼的代码在起点相同的情况下可以删除。起点不同是不能删除的。
页:
[1]