删除完全重复的多段线

树櫴希德 · 发表于 2016-1-20 15:07:04

(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")))
i 0
)
(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)
)

(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"))) 
       i  0 
       ) 
  (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) 
)

Real_King · 发表于 2016-1-20 15:22:11

不错，很有实用价值

Y~_H_~K · 发表于 2016-2-19 13:58:22

楼主你也是做测量的吗?

树櫴希德 · 发表于 2016-9-13 20:38:44

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)
;@[stoyer]起点或者方向不同的两个多边形，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")))
i 0
)
(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)
)

(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) 
 
;@[stoyer]起点或者方向不同的两个多边形，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"))) 
       i  0 
       ) 
  (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) 
)

mattran · 发表于 2016-9-26 16:13:49

厉害~~~~~~~~~~~~~~~~~~~

尘缘一生 · 发表于 2020-5-26 23:52:40

树櫴希德发表于 2016-9-13 20:38
73哥函数删除完全重复多段线包括重复但起点或终点不同或者方向不同但投影重复

次代码不能成功，希望完善

树櫴希德 · 发表于 2020-10-14 10:56:27

(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轴

f4800 · 发表于 2020-10-30 21:52:25

(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")))
   i  0
   )
  (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)
)

赞一个。。。。

vladimirputin · 发表于 2021-1-29 14:54:44

非常不错的代码，谢谢楼主分享

skg123 · 发表于 2021-5-27 20:35:31

本帖最后由 skg123 于 2021-5-29 00:21 编辑

测试了一下，1楼的代码在起点相同的情况下可以删除。起点不同是不能删除的。

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

删除完全重复的多段线

评分

相关帖子

本帖子中包含更多资源

本帖子中包含更多资源