设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 行业篇 › AutoCAD与GIS测绘 › 删除完全重复的多段线
返回列表 发新帖
查看: 2872|回复: 9

删除完全重复的多段线

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

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





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


  73.            
  74.            
  75.            )
  76.          )
  77.          (alert "报告老大，没有找到重叠块！")
  78.      )
  79.     )
  80.     (alert "老大，这么简单的问题自己解决！")
  81.    )
  82.    (princ)
  83. )
lambda, while, cond, 名表, 互转

评分

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

查看全部评分

相关帖子
回复

使用道具 举报

Real_King
发表于 2016-1-20 15:22:11 | 显示全部楼层
不错，很有实用价值
回复 支持 反对

使用道具 举报

Y~_H_~K
发表于 2016-2-19 13:58:22 | 显示全部楼层
  楼主  你也是做测量的吗?
回复 支持 反对

使用道具 举报

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


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

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

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

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

  37. (defun vxs (e / i v lst)
  38.   (setq i 0)
  39.   (while
  40.     (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
  41.      (setq lst (cons v lst))
  42.   )
  43.   (reverse lst))

  45. ;选择集与对象名表互转
  46. (defun cx-ss2en
  47.   (ss / enlst)
  48.   (cond
  49.     ((= (type ss) 'PICKSET)
  50.       (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
  51.     )
  52.     ((= (type ss) 'LIST)
  53.       (setq enlst (ssadd))
  54.       (last (mapcar '(lambda (x) (ssadd x enlst)) ss))
  55.     )
  56.     ((='ename(type ss))
  57.       (ssadd ss)
  58.     )
  59.   )
  60. )





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


  108.            
  109.            
  110.            )
  111.          )
  112.          (alert "报告老大，没有找到重叠块！")
  113.      )
  114.     )
  115.     (alert "老大，这么简单的问题自己解决！")
  116.    )
  117.    (princ)
  118. )
回复 支持 反对

使用道具 举报

尘缘一生
发表于 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轴

本帖子中包含更多资源

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

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楼的代码在起点相同的情况下可以删除。起点不同是不能删除的。

本帖子中包含更多资源

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

x
回复 支持 反对

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-12-23 09:06 , Processed in 0.194291 second(s), 28 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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