明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 2458|回复: 9

删除完全重复的多段线

[复制链接]
发表于 2016-1-20 15:07 | 显示全部楼层 |阅读模式
  1. (defun vxs (e / i v lst)
  2.   (setq i 0)
  3.   (while
  4.     (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
  5.      (setq lst (cons v lst))
  6.   )
  7.   (reverse lst))

  8. ;选择集与对象名表互转
  9. (defun cx-ss2en
  10.   (ss / enlst)
  11.   (cond
  12.     ((= (type ss) 'PICKSET)
  13.       (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
  14.     )
  15.     ((= (type ss) 'LIST)
  16.       (setq enlst (ssadd))
  17.       (last (mapcar '(lambda (x) (ssadd x enlst)) ss))
  18.     )
  19.     ((='ename(type ss))
  20.       (ssadd ss)
  21.     )
  22.   )
  23. )





  24. ;货物分两组(样品 库存)
  25. (defun lst->2lst(lst / lst1 lst2)
  26.   (setq lst1 '() lst2 '())
  27. (foreach a lst
  28.     (if (member a lst2)
  29.       (setq lst1 (cons a lst1))
  30.       (setq lst2 (cons a lst2))
  31.     )
  32.   )
  33. (cons (reverse lst2) (reverse lst1))
  34. )
  35. ;检查重叠块
  36. (defun c:chk_poly (/ ss pt s1 dxf2 dxf41 dxf50 ss1 i)
  37.   (setq ss (ssget '((0 . "*polyline")))
  38.        i  0
  39.        )
  40.   (if (and ss (> (sslength ss) 2))
  41.    (progn
  42.     (setq entlst (cx-ss2en ss)
  43.           ptlst (mapcar '(lambda(x) (vxs x)) entlst)
  44.           2ptlst (lst->2lst ptlst)
  45.           )
  46.      (if (cdr 2ptlst)
  47.        (progn
  48.          ;(setq pt (getpoint "引出点:"))
  49.          (foreach x (cdr 2ptlst)
  50.            ;(entmake (list '(0 . "line") '(8 . "0-辅助层tem") (cons 62 1) x (cons 11 pt)))
  51. (repeat (setq k (length (cdr 2ptlst)))
  52.     (if  (and (setq e (ssname ss (setq k (1- k ))))
  53.        (setq en (entget e))
  54.   )
  55.       (progn  
  56.   
  57.   (if (equal x (vxs e))
  58.     (entdel e)
  59.     ;(setq en (cons x en))
  60.   )
  61.       )
  62.     )
  63.   )


  64.            
  65.            
  66.            )
  67.          )
  68.          (alert "报告老大,没有找到重叠块!")
  69.      )
  70.     )
  71.     (alert "老大,这么简单的问题自己解决!")
  72.    )
  73.    (princ)
  74. )

评分

参与人数 1明经币 +1 收起 理由
USER2128 + 1 赞一个!

查看全部评分

发表于 2016-1-20 15:22 | 显示全部楼层
不错,很有实用价值
发表于 2016-2-19 13:58 | 显示全部楼层
  楼主  你也是做测量的吗?
 楼主| 发表于 2016-9-13 20:38 | 显示全部楼层
73哥函数 删除完全重复多段线 包括重复但起点或终点不同 或者方向不同 但投影重复


  1. (defun Plinexy(e / p a b n ob q et d d1 en et) ;;多线段节点坐标(滤掉了多余点,未处理假闭合)
  2.    (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)
  3.    (cond((="LWPOLYLINE"et)
  4.          (repeat(length a)(setq b (nth n a) n (+ n 1))
  5.            (if (= 10 (car b))(progn
  6.                                (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))
  7.                                (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
  8.                                  (setq p (list q))))
  9.              )))
  10.         ((="POLYLINE"et)
  11.          (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))
  12.          (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")
  13.            (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))
  14.            (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
  15.              (setq p (list q)))
  16.            (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))
  17.          (setq p(reverse p))
  18.          ))
  19.    P)

  20. ;@[stoyer]起点或者方向不同的两个多边形,CAD不会认为它们相同,但是用数学上集合的概念来对待它们的顶点表就好了
  21. (defun remove(l e fun)(vl-remove'nil(mapcar'(lambda(x)(if(not(equal x e fun))x))l)))
  22. (defun lst-(l1 l2 fun)(foreach x l2(setq l1(remove l1 x fun)))l1)
  23. ;用lst-求两个多边形顶点坐标表的差集,如果为nil那么这两个多边形它们是相同的,不管它们起点以及方向是否相同
  24. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25. ;(lst- (plinexy pzx) (plinexy lll) 1)

  26. ;令: (plinexy pzx)
  27. ;((138.117 32.0953) (159.105 69.993) (130.531 80.3517) (115.359 48.7703))

  28. ;命令: (plinexy opo)
  29. ;((130.531 80.3517) (115.359 48.7703) (138.117 32.0953) (159.105 69.993))

  30. (defun vxs (e / i v lst)
  31.   (setq i 0)
  32.   (while
  33.     (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
  34.      (setq lst (cons v lst))
  35.   )
  36.   (reverse lst))

  37. ;选择集与对象名表互转
  38. (defun cx-ss2en
  39.   (ss / enlst)
  40.   (cond
  41.     ((= (type ss) 'PICKSET)
  42.       (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
  43.     )
  44.     ((= (type ss) 'LIST)
  45.       (setq enlst (ssadd))
  46.       (last (mapcar '(lambda (x) (ssadd x enlst)) ss))
  47.     )
  48.     ((='ename(type ss))
  49.       (ssadd ss)
  50.     )
  51.   )
  52. )





  53. ;货物分两组(样品 库存)
  54. (defun lst->2lst(lst / lst1 lst2)
  55.   (setq lst1 '() lst2 '())
  56. (foreach a lst
  57.     (if (or (member a lst2) (vl-some'(lambda(x)(not(lst- a x 0))) lst2))
  58.       (setq lst1 (cons a lst1))
  59.       (setq lst2 (cons a lst2))
  60.     )
  61.   )
  62. (cons (reverse lst2) (reverse lst1))
  63. )
  64. ;检查重叠块
  65. (defun c:chk_poly (/ ss pt s1 dxf2 dxf41 dxf50 ss1 i)
  66.   (setq ss (ssget '((0 . "*polyline")))
  67.        i  0
  68.        )
  69.   (if (and ss (> (sslength ss) 2))
  70.    (progn
  71.     (setq entlst (cx-ss2en ss)
  72.           ptlst (mapcar '(lambda(x) (Plinexy x)) entlst)
  73.           2ptlst (lst->2lst ptlst)
  74.           )
  75.      (if (cdr 2ptlst)
  76.        (progn
  77.          ;(setq pt (getpoint "引出点:"))
  78.          (foreach x (cdr 2ptlst)
  79.            ;(entmake (list '(0 . "line") '(8 . "0-辅助层tem") (cons 62 1) x (cons 11 pt)))
  80. (repeat (setq k (length (cdr 2ptlst)))
  81.     (if  (and (setq e (ssname ss (setq k (1- k ))))
  82.        (setq en (entget e))
  83.   )
  84.       (progn  
  85.   
  86.   (if (equal x (Plinexy e))
  87.     (entdel e)
  88.     ;(setq en (cons x en))
  89.   )
  90.       )
  91.     )
  92.   )


  93.            
  94.            
  95.            )
  96.          )
  97.          (alert "报告老大,没有找到重叠块!")
  98.      )
  99.     )
  100.     (alert "老大,这么简单的问题自己解决!")
  101.    )
  102.    (princ)
  103. )
发表于 2020-5-26 23:52 | 显示全部楼层
树櫴希德 发表于 2016-9-13 20:38
73哥函数 删除完全重复多段线 包括重复但起点或终点不同 或者方向不同 但投影重复

次代码不能成功,希望完善
 楼主| 发表于 2020-10-14 10:56 | 显示全部楼层
(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轴

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
发表于 2020-10-30 21:52 | 显示全部楼层
(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)
)


赞一个。。。。
发表于 2021-1-29 14:54 | 显示全部楼层
非常不错的代码,谢谢楼主分享
发表于 2021-5-27 20:35 | 显示全部楼层
本帖最后由 skg123 于 2021-5-29 00:21 编辑

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

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-29 21:40 , Processed in 0.226751 second(s), 31 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表