设为首页收藏本站

晓东CAD家园-论坛

 找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 670|回复: 7

[每日一码] 多段线顶点“消重”

[复制链接]

已领礼包: 20个

财富等级: 恭喜发财

发表于 2018-5-8 11:12:32 | 显示全部楼层 |阅读模式

马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。

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

x
可以设置误差,指定长度内的顶点都算重合顶点,消除

  1. ;;Program to Simplify Pline vertices given a polyline and Max allowed error.
  2. ;;Will remove bulges (arcs).
  3. ;;
  4. ;;By Steve Carson
  5. ;;
  6. ;;
  7. ;;
  8. ;;

  9. (vl-load-com)

  10. (defun C:Simplify ( / SS MAXERR COUNTS TOT RTOT)
  11.   (setq TOT 0 RTOT 0)
  12.   (princ "\nSelect Polyline(s) to process (<Enter> for all): ")
  13.   (cond
  14.    ((setq SS (ssget '((0 . "POLYLINE,LWPOLYLINE")) )) (princ))
  15.    ((setq SS (ssget "_A" '((0 . "POLYLINE,LWPOLYLINE")) )) (princ))
  16.    (T (princ "\nNo Polylines exist!"))
  17.   )
  18.   (if SS
  19.    (progn
  20.      (setq MAXERR (getreal "\nEnter maximum error: "))
  21.      (if (< (abs MAXERR) 0.00000001)
  22.          (setq MAXERR 0.000000005)
  23.          (setq MAXERR (abs MAXERR))
  24.      );if
  25.      (repeat (sslength SS)
  26.        (setq COUNTS (SC:Simplify MAXERR (ssname SS 0) (sslength SS)))
  27.        (setq TOT (+ (car COUNTS) TOT) RTOT (+ (cdr COUNTS) RTOT))
  28.        (ssdel (ssname SS 0) SS)
  29.      );repeat
  30.      (princ (strcat "\nA total of " (itoa TOT) " vertices were simplified to " (itoa RTOT)))
  31.    );progn
  32.   );if
  33.   (princ)
  34. );defun




  35. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ;;
  38. ;;Main Simplification code
  39. ;;
  40. ;;By Steve Carson
  41. ;;

  42. (defun SC:Simplify ( MaxErr Pline ObjNum / ERR OBJ PL1 PL2 S E EINX CHK NL A SA CNT I)

  43. ;Set Variables
  44.   (setq ERR MaxErr
  45.         OBJ Pline)

  46.   (if (= (cdr (assoc 0 (entget Pline))) "LWPOLYLINE")
  47.     (setq PL1 (SC:IndexPline OBJ))
  48.     (setq PL1 (SC:Index3DPline OBJ))
  49.   )

  50.   (setq PL2 (list (car PL1) (last PL1))                       ; New Pline
  51.           S (car PL2)                                         ; First Element of Pline
  52.           E (cadr PL2)                                        ; Last Element of Pline
  53.        EINX (car E)                                           ; Ending Index
  54.         CHK nil
  55.          NL '()
  56.           I 0
  57.   )

  58. ;Remove Bulges
  59.   (cond
  60.    ((= (cdr (assoc 0 (entget Pline))) "LWPOLYLINE")
  61.      (repeat (length PL1)
  62.       (vla-SetBulge (vlax-ename->vla-object OBJ) I 0.0)
  63.       (setq I (1+ I))
  64.      )
  65.    )
  66.    ((= (cdr (assoc 0 (entget Pline))) "POLYLINE")
  67.      (if (and (= (vla-get-type (vlax-ename->vla-object OBJ)) 0)
  68.               (vlax-method-applicable-p (vlax-ename->vla-object OBJ) 'SetBulge)
  69.          )
  70.         (repeat (length PL1)
  71.           (vla-SetBulge (vlax-ename->vla-object OBJ) I 0.0)
  72.           (setq I (1+ I))
  73.         )
  74.      );if
  75.    )
  76.   )

  77. (if acet-ui-progress (acet-ui-progress (strcat (itoa ObjNum) " objects remaining. Current object progress: ") EINX))

  78. (while (null CHK)

  79.   (if acet-ui-progress (acet-ui-progress (car S)))

  80. (if (> (- (car E) (car S)) 1)
  81.   (progn
  82.    ;Determine point on PL1 that is farthest away from PL2
  83.    (setq A (SC:GetMaxDist (cdr S) (cdr E) (SC:ListBetween (car S) (car E) PL1)))
  84.    (cond

  85.     ;If the max distance is less than the max error AND the second element equals the end point, setq CHK to T
  86.     ( (and (< (car A) ERR) (= (car E) EINX))   (setq CHK T) )

  87.     ;If the max dist is greater than max error, add point to list and set new point to E
  88.     ( (> (car A) ERR)   (setq PL2 (SC:SortByFirst (append (list (cdr A)) PL2)) E (cdr A)) )

  89.     ;If the max dist is less than max error, set S and E to next points
  90.     ( (< (car A) ERR)   (setq S E E (SC:ListNext E PL2))  )

  91.    );cond
  92.   );progn
  93.   (if (= (car E) EINX) (setq CHK T) (setq S E E (SC:ListNext E PL2)))

  94. );if

  95. );while

  96. (if acet-ui-progress (acet-ui-progress))
  97. (setq CNT (length PL2))

  98. ;Create new Pline from PL2 list
  99. (foreach P (reverse PL2)
  100.   (setq NL (append (cdr P) NL))
  101. );foreach

  102. ;Make a safearray of the coordinates
  103. (setq SA (vlax-safearray-fill
  104.             (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length NL))))
  105.                 NL
  106.          )
  107. )

  108. ;Modify Pline
  109. (vlax-put-property (vlax-ename->vla-object OBJ) 'Coordinates (vlax-make-variant SA))
  110. (princ (strcat "\n" (itoa (1+ EINX)) " points simplified to " (itoa CNT)))
  111. (cons (1+ EINX) CNT)
  112. );defun



  113. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  114. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  115. ;;
  116. ;;Sort a list by first element
  117. ;;
  118. ;;By Steve Carson
  119. ;;

  120. (defun SC:SortByFirst (L / )
  121.   (vl-sort L (function (lambda (a b) (< (car a) (car b)))))
  122. )



  123. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  124. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  125. ;;
  126. ;;Get Maximum Distance
  127. ;;By Steve Carson
  128. ;;
  129. ;;Returns list element and distance that is farthest away from a line drawn between 2 points
  130. ;;List needs to be in the form ((1 X1 Y1) (2 X2 Y2) ... (n Xn Yn))
  131. ;;Returned list is in the form (d n Xn Yn)
  132. ;;Also works for lists including a Z value and returns a list with a Z value.

  133. (defun SC:GetMaxDist (p1 p2 lst / d d2 i)
  134.    (setq d 0)
  135.    (foreach l lst
  136.      (if (> (setq d2 (SC:DistToLine (cdr l) p1 p2)) d)
  137.          (setq d d2 i l)
  138.      )
  139.    )
  140.    (cons d i)

  141. );defun



  142. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  143. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  144. ;;
  145. ;;List between indices
  146. ;;By Steve Carson
  147. ;;
  148. ;;Returns a non-inclusive list of items between 2 indices given 2 indices and a list
  149. ;;List needs to be in the form ((1 X1 Y1) (2 X2 Y2) ... (n Xn Yn))
  150. ;;or ((1 X1 Y1 Z1) (2 X2 Y2 Z2) ... (n Xn Yn Zn))

  151. (defun SC:ListBetween (indx1 indx2 lst / n i l)
  152.   (setq n (1- (- indx2 indx1))
  153.         i indx1
  154.         l '()
  155.   )
  156.   (repeat n
  157.     (setq l (cons (nth (setq i (1+ i)) lst) l))
  158.   )
  159.   (reverse l)

  160. )



  161. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  162. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  163. ;;
  164. ;;Perpendicular Distance of a point (p1) to a line defined by 2 points (p2 p3)
  165. ;;By Steve Carson
  166. ;;
  167. ;;Uses the numerically stable version of "Heron's Formula" shown on Wikipedia to find
  168. ;;the area of the triangle formed by the 3 points, then multiplies it by 2 to get the
  169. ;;area of the rectangle, then divides by the length of the line to get the width of the
  170. ;;rectangle, which is the perpendicular distance required.

  171. (defun SC:DistToLine ( pt1 pt2 pt3 / LIN A B C A1 B1 C1)


  172. (if (equal pt2 pt3 0.0001)
  173. (distance pt1 pt2)
  174. (progn
  175. (setq LIN (distance pt2 pt3) A (distance pt1 pt2) B (distance pt1 pt3) C LIN)

  176. ;Sorts lengths so A1<=B1<=C1
  177. (cond
  178.   ((<= A B C) (setq A1 A B1 B C1 C))
  179.   ((<= A C B) (setq A1 A B1 C C1 B))
  180.   ((<= B A C) (setq A1 B B1 A C1 C))
  181.   ((<= B C A) (setq A1 B B1 C C1 A))
  182.   ((<= C A B) (setq A1 C B1 A C1 B))
  183.   ((<= C B A) (setq A1 C B1 B C1 A))
  184.   (T (setq A1 A B1 B C1 C))
  185. );cond

  186. (if (and (not (equal A1 0.0 0.0001))
  187.           (not (equal B1 0.0 0.0001))
  188.           (not (equal C1 0.0 0.0001)))
  189.   (/
  190.           (sqrt
  191.            (abs
  192.             (*
  193.              (+ A1 (+ B1 C1))
  194.              (- C1 (- A1 B1))
  195.              (+ C1 (- A1 B1))
  196.              (+ A1 (- B1 C1))
  197.             );*
  198.            );abs
  199.           );sqrt

  200.           (* 2 LIN)
  201.   );/
  202.   0
  203. );if
  204. );progn
  205. );if
  206. )


  207. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  208. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  209. ;;
  210. ;;Index Pline vertices
  211. ;;By Steve Carson
  212. ;;
  213. ;;
  214. ;;Returns a list of coordinates in the form:
  215. ;;((1 X1 Y1) (2 X2 Y2) ... (n Xn Yn))

  216. (defun SC:IndexPline (ent / P C1 C2 IDX)
  217.   (setq C1 (vlax-safearray->list
  218.                (vlax-variant-value
  219.                    (vla-get-coordinates
  220.                        (vlax-ename->vla-object ent)
  221.                    )
  222.                )
  223.            )
  224.         IDX 0
  225.         C2 (list (list IDX (car C1) (cadr C1)))
  226.         C1 (cddr C1)
  227.   )
  228.   (repeat (/ (length C1) 2)
  229.     (setq C2 (cons (list (setq IDX (1+ IDX))  (car C1) (cadr C1)) C2)
  230.           C1 (cddr C1)
  231.     )
  232.   );repeat
  233.   (reverse C2)
  234. );defun



  235. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  236. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  237. ;;
  238. ;;Index 3DPline vertices
  239. ;;By Steve Carson
  240. ;;
  241. ;;
  242. ;;Returns a list of coordinates in the form:
  243. ;;((1 X1 Y1 Z1) (2 X2 Y2 Z2) ... (n Xn Yn Zn))

  244. (defun SC:Index3DPline (ent / P C1 C2 IDX)
  245.   (setq C1 (vlax-safearray->list
  246.                (vlax-variant-value
  247.                    (vla-get-coordinates
  248.                        (vlax-ename->vla-object ent)
  249.                     )
  250.                 )
  251.             )
  252.         IDX 0
  253.         C2 (list (list IDX (car C1) (cadr C1) (caddr C1)))
  254.         C1 (cdddr C1)
  255.   )
  256.   (repeat (/ (length C1) 3)
  257.     (setq C2 (cons (list (setq IDX (1+ IDX))  (car C1) (cadr C1) (caddr C1)) C2)
  258.           C1 (cdddr C1)
  259.     )
  260.   );repeat
  261.   (reverse C2)
  262. );defun




  263. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  264. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  265. ;;
  266. ;;Next List Element
  267. ;;By Steve Carson
  268. ;;
  269. ;;Given an element and a list, returns the next element in the list.
  270. ;;Returns nil if element is last element of list, or is not in the list.

  271. (defun SC:ListNext (E L / A N)
  272.   (if (setq A (member E L))
  273.        (progn
  274.         (setq N (1+ (- (length L) (length A))))
  275.         (if (< N (length L))
  276.             (nth N L)
  277.             nil
  278.         )
  279.        )
  280.        nil
  281.   )
  282. );defun



  283. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  284. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  285. (princ "\nType \"SIMPLIFY\" to invoke.")
  286. (princ)


评分

参与人数 1D豆 +5 收起 理由
sh_h + 5 很给力!经验;技术要点;资料分享奖!

查看全部评分

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!

已领礼包: 767个

财富等级: 财运亨通

发表于 2018-5-8 16:01:41 | 显示全部楼层
大师分享的都是精品啊,收藏了!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 1336个

财富等级: 财源广进

发表于 2018-5-8 20:10:42 | 显示全部楼层
谢谢老大这个真是及时雨,我自己写了一个,效果不理想,就用这个了,谢谢!就是解决不完全共线的点删除这些。。。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 6468个

财富等级: 富甲天下

发表于 2018-5-9 00:11:14 | 显示全部楼层
谢谢分享。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复

使用道具 举报

已领礼包: 23个

财富等级: 恭喜发财

发表于 2018-5-9 00:14:16 来自手机 | 显示全部楼层
感谢分享。。。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复

使用道具 举报

已领礼包: 219个

财富等级: 日进斗金

发表于 2018-5-11 06:11:25 | 显示全部楼层
感谢楼主谢谢分享。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 3个

财富等级: 恭喜发财

发表于 2021-3-4 12:29:35 | 显示全部楼层
有用, mark
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复

使用道具 举报

发表于 2022-8-4 18:43:59 | 显示全部楼层
谢谢大神的分享
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

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

本版积分规则

QQ|申请友链|小黑屋|手机版|Archiver|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )  

GMT+8, 2022-8-18 16:05 , Processed in 0.175891 second(s), 30 queries , Gzip On, WinCache On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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