LWPOLYLINE清除冗余点，合并同向段

marting · 发表于 2017-5-11 16:30:36

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

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

×

(defun purge-pline (pl / regular-width colinear concentric
del-cadr pour-car elst closed old-p old-b
old-sw old-ew new-d new-p new-b new-sw
new-ew b1 b2
)
;; Evaluates if the pline width is regular on 3 successive points
(defun regular-width (p1 p2 p3 ws1 we1 ws2 we2 / delta)
(or (= ws1 we1 ws2 we2)
(and (= we1 ws2)
(/= 0 (setq delta (- we2 ws1)))
(equal (/ (- (vlax-curve-getDistAtPoint pl (trans p2 pl 0))
(vlax-curve-getDistAtPoint pl (trans p1 pl 0))
)
(- (vlax-curve-getDistAtPoint pl (trans p3 pl 0))
(vlax-curve-getDistAtPoint pl (trans p1 pl 0))
)
)
(/ (- we1 (- we2 delta)) delta)
1e-9
)
)
)
);; Evaluates if 3 successive vertices are aligned
(defun colinear (p1 p2 p3 b1 b2)
(and (zerop b1)
(zerop b2)
(null (inters p1 p2 p1 p3)
)
)
);; Evaluates if 3 sucessive vertices have the same center
(defun concentric (p1 p2 p3 b1 b2 / bd1 bd2)
(if
(and (/= 0.0 b1)
(/= 0.0 b2)
(equal
(caddr (setq bd1 (BulgeData b1 p1 p2)))
(caddr (setq bd2 (BulgeData b2 p2 p3)))
1e-9
)
)
(tan (/ (+ (car bd1) (car bd2)) 4.0))
)
) ;; Removes the second item of the list
(defun del-cadr (lst)
(set lst (cons (car (eval lst)) (cddr (eval lst))))
) ;; Pours the first item of a list to another one
(defun pour-car (from to)
(set to (cons (car (eval from)) (eval to)))
(set from (cdr (eval from)))
)
(setq elst (entget pl))
(and (= 1 (logand 1 (cdr (assoc 70 elst)))) (setq closed T))
(mapcar (function (lambda (x)
(cond
((= (car x) 10) (setq old-p (cons x old-p)))
((= (car x) 40) (setq old-sw (cons x old-sw)))
((= (car x) 41) (setq old-ew (cons x old-ew)))
((= (car x) 42) (setq old-b (cons x old-b)))
(T (setq new-d (cons x new-d)))
)
)
)
elst
)
(mapcar (function (lambda (l)
(set l (reverse (eval l)))
)
)
'(old-p old-sw old-ew old-b new-d)
)
(and closed (setq old-p (append old-p (list (car old-p)))))
(and (equal (cdar old-p) (cdr (last old-p)) 1e-9)
(setq closed T
new-d (subst (cons 70 (Boole 7 (cdr (assoc 70 new-d)) 1))
(assoc 70 new-d)
new-d
)
)
)
(while (cddr old-p)
(if (regular-width
(cdar old-p)
(cdadr old-p)
(cdaddr old-p)
(cdar old-sw)
(cdar old-ew)
(cdadr old-sw)
(cdadr old-ew)
)
(cond
((colinear (cdar old-p)
(cdadr old-p)
(cdaddr old-p)
(cdar old-b)
(cdadr old-b)
)
(mapcar 'del-cadr '(old-p old-sw old-ew old-b))
)
((setq bu (concentric
(cdar old-p)
(cdadr old-p)
(cdaddr old-p)
(cdar old-b)
(cdadr old-b)
)
)
(setq old-b (cons (cons 42 bu) (cddr old-b)))
(mapcar 'del-cadr '(old-p old-sw old-ew))
)
(T
(mapcar 'pour-car
'(old-p old-sw old-ew old-b)
'(new-p new-sw new-ew new-b)
)
)
)
(mapcar 'pour-car
'(old-p old-sw old-ew old-b)
'(new-p new-sw new-ew new-b)
)
)
)
(if closed
(setq new-p (reverse (cons (car old-p) new-p)))
(setq new-p (append (reverse new-p) old-p))
)
(mapcar
(function
(lambda (new old)
(set new (append (reverse (eval new)) (eval old)))
)
)
'(new-sw new-ew new-b)
'(old-sw old-ew old-b)
)
(if (and closed
(regular-width
(cdr (last new-p))
(cdar new-p)
(cdadr new-p)
(cdr (last new-sw))
(cdr (last new-ew))
(cdar new-sw)
(cdar new-ew)
)
)
(cond
((colinear (cdr (last new-p))
(cdar new-p)
(cdadr new-p)
(cdr (last new-b))
(cdar new-b)
)
(mapcar (function (lambda (l)
(set l (cdr (eval l)))
)
)
'(new-p new-sw new-ew new-b)
)
)
((setq bu (concentric
(cdr (last new-p))
(cdar new-p)
(cdadr new-p)
(cdr (last new-b))
(cdar new-b)
)
)
(setq new-b (cdr (reverse (cons (cons 42 bu) (cdr (reverse new-b))))))
(mapcar (function (lambda (l)
(set l (cdr (eval l)))
)
)
'(new-p new-sw new-ew)
)
)
)
)
(entmod
(append new-d
(apply 'append
(apply 'mapcar
(cons 'list (list new-p new-sw new-ew new-b))
)
)
)
)
);; BulgeData Retourne les données d'un polyarc (angle rayon centre)
(defun BulgeData (bu p1 p2 / ang rad cen)
(setq ang (* 2 (atan bu))
rad (/ (distance p1 p2)
(* 2 (sin ang))
)
cen (polar p1
(+ (angle p1 p2) (- (/ pi 2) ang))
rad
)
)
(list (* ang 2.0) rad cen)
);; TAN Retourne la tangente de l'angle
(defun tan (ang)
(/ (sin ang) (cos ang))
);; SPL Calling function
(defun c:spl (/ ss n pl)
(vl-load-com)
(or *acad* (setq *acad* (vlax-get-acad-object)))
(or *acdoc* (setq *acdoc* (vla-get-ActiveDocument *acad*)))
(princ
"\nSelect les polylines to be treated or <All>: "
)
(or
(setq ss (ssget '((0 . "LWPOLYLINE"))))
(setq ss (ssget "_X" '((0 . "LWPOLYLINE"))))
)
(if
ss
(progn
(vla-StartUndoMark *acdoc*)
(setq n -1)
(while (setq pl (ssname ss (setq n (1+ n))))
(purge-pline pl)
)
(princ (strcat "\n\t" (itoa n) " treated polyline(s)."))
(vla-EndUndoMark *acdoc*)
)
(princ "\nNone selected polyline.")
)
(princ)
)
(princ
"\nSimp-Pline loaded, type SPL to launch the function."
)
(princ)

(defun purge-pline (pl              /                regular-width            colinear  concentric 
                    del-cadr  pour-car        elst          closed    old-p     old-b 
                    old-sw    old-ew        new-d          new-p            new-b     new-sw 
                    new-ew    b1        b2 
                   ) 
;; Evaluates if the pline width is regular on 3 successive points 
  (defun regular-width (p1 p2 p3 ws1 we1 ws2 we2 / delta) 
    (or        (= ws1 we1 ws2 we2) 
        (and (= we1 ws2) 
             (/= 0 (setq delta (- we2 ws1))) 
             (equal (/ (- (vlax-curve-getDistAtPoint pl (trans p2 pl 0)) 
                          (vlax-curve-getDistAtPoint pl (trans p1 pl 0)) 
                       ) 
                       (- (vlax-curve-getDistAtPoint pl (trans p3 pl 0)) 
                          (vlax-curve-getDistAtPoint pl (trans p1 pl 0)) 
                       ) 
                    ) 
                    (/ (- we1 (- we2 delta)) delta) 
                    1e-9 
             ) 
        ) 
    ) 
  );; Evaluates if 3 successive vertices are aligned 
  (defun colinear (p1 p2 p3 b1 b2) 
    (and (zerop b1) 
         (zerop b2) 
         (null (inters p1 p2 p1 p3) 
         ) 
    ) 
  );; Evaluates if 3 sucessive vertices have the same center 
  (defun concentric (p1 p2 p3 b1 b2 / bd1 bd2) 
    (if 
      (and (/= 0.0 b1) 
           (/= 0.0 b2) 
           (equal 
             (caddr (setq bd1 (BulgeData b1 p1 p2))) 
             (caddr (setq bd2 (BulgeData b2 p2 p3))) 
             1e-9 
           ) 
      ) 
       (tan (/ (+ (car bd1) (car bd2)) 4.0)) 
    ) 
  )  ;; Removes the second item of the list 
  (defun del-cadr (lst) 
    (set lst (cons (car (eval lst)) (cddr (eval lst)))) 
  ) ;; Pours the first item of a list to another one 
  (defun pour-car (from to) 
    (set to (cons (car (eval from)) (eval to))) 
    (set from (cdr (eval from))) 
  ) 
  (setq elst (entget pl)) 
  (and (= 1 (logand 1 (cdr (assoc 70 elst)))) (setq closed T)) 
  (mapcar (function (lambda (x) 
                      (cond 
                        ((= (car x) 10) (setq old-p (cons x old-p))) 
                        ((= (car x) 40) (setq old-sw (cons x old-sw))) 
                        ((= (car x) 41) (setq old-ew (cons x old-ew))) 
                        ((= (car x) 42) (setq old-b (cons x old-b))) 
                        (T (setq new-d (cons x new-d))) 
                      ) 
                    ) 
          ) 
          elst 
  ) 
  (mapcar (function (lambda (l) 
                      (set l (reverse (eval l))) 
                    ) 
          ) 
          '(old-p old-sw old-ew old-b new-d) 
  ) 
  (and closed (setq old-p (append old-p (list (car old-p))))) 
  (and (equal (cdar old-p) (cdr (last old-p)) 1e-9) 
       (setq closed T 
             new-d  (subst (cons 70 (Boole 7 (cdr (assoc 70 new-d)) 1)) 
                           (assoc 70 new-d) 
                           new-d 
                    ) 
       ) 
  ) 
  (while (cddr old-p) 
    (if        (regular-width 
          (cdar old-p) 
          (cdadr old-p) 
          (cdaddr old-p) 
          (cdar old-sw) 
          (cdar old-ew) 
          (cdadr old-sw) 
          (cdadr old-ew) 
        ) 
      (cond 
        ((colinear (cdar old-p) 
                   (cdadr old-p) 
                   (cdaddr old-p) 
                   (cdar old-b) 
                   (cdadr old-b) 
         ) 
         (mapcar 'del-cadr '(old-p old-sw old-ew old-b)) 
        ) 
        ((setq bu (concentric 
                    (cdar old-p) 
                    (cdadr old-p) 
                    (cdaddr old-p) 
                    (cdar old-b) 
                    (cdadr old-b) 
                  ) 
         ) 
         (setq old-b (cons (cons 42 bu) (cddr old-b))) 
         (mapcar 'del-cadr '(old-p old-sw old-ew)) 
        ) 
        (T 
         (mapcar 'pour-car 
                 '(old-p old-sw old-ew old-b) 
                 '(new-p new-sw new-ew new-b) 
         ) 
        ) 
      ) 
      (mapcar 'pour-car 
              '(old-p old-sw old-ew old-b) 
              '(new-p new-sw new-ew new-b) 
      ) 
    ) 
  ) 
  (if closed 
    (setq new-p (reverse (cons (car old-p) new-p))) 
    (setq new-p (append (reverse new-p) old-p)) 
  ) 
  (mapcar 
    (function 
      (lambda (new old) 
        (set new (append (reverse (eval new)) (eval old))) 
      ) 
    ) 
    '(new-sw new-ew new-b) 
    '(old-sw old-ew old-b) 
  ) 
  (if (and closed 
           (regular-width 
             (cdr (last new-p)) 
             (cdar new-p) 
             (cdadr new-p) 
             (cdr (last new-sw)) 
             (cdr (last new-ew)) 
             (cdar new-sw) 
             (cdar new-ew) 
           ) 
      ) 
    (cond 
      ((colinear (cdr (last new-p)) 
                 (cdar new-p) 
                 (cdadr new-p) 
                 (cdr (last new-b)) 
                 (cdar new-b) 
       ) 
       (mapcar (function (lambda (l) 
                           (set l (cdr (eval l))) 
                         ) 
               ) 
               '(new-p new-sw new-ew new-b) 
       ) 
      ) 
      ((setq bu        (concentric 
                  (cdr (last new-p)) 
                  (cdar new-p) 
                  (cdadr new-p) 
                  (cdr (last new-b)) 
                  (cdar new-b) 
                ) 
       ) 
       (setq new-b (cdr (reverse (cons (cons 42 bu) (cdr (reverse new-b)))))) 
       (mapcar (function (lambda (l) 
                           (set l (cdr (eval l))) 
                         ) 
               ) 
               '(new-p new-sw new-ew) 
       ) 
      ) 
    ) 
  ) 
  (entmod 
    (append new-d 
            (apply 'append 
                   (apply 'mapcar 
                          (cons 'list (list new-p new-sw new-ew new-b)) 
                   ) 
            ) 
    ) 
  ) 
);; BulgeData Retourne les données d'un polyarc (angle rayon centre) 
(defun BulgeData (bu p1 p2 / ang rad cen) 
  (setq        ang (* 2 (atan bu)) 
        rad (/ (distance p1 p2) 
               (* 2 (sin ang)) 
            ) 
        cen (polar p1 
                   (+ (angle p1 p2) (- (/ pi 2) ang)) 
                   rad 
            ) 
  ) 
  (list (* ang 2.0) rad cen) 
);; TAN Retourne la tangente de l'angle 
(defun tan (ang) 
  (/ (sin ang) (cos ang)) 
);; SPL Calling function 
(defun c:spl (/ ss n pl) 
  (vl-load-com) 
  (or *acad* (setq *acad* (vlax-get-acad-object))) 
  (or *acdoc* (setq *acdoc* (vla-get-ActiveDocument *acad*))) 
  (princ 
    "\nSelect les polylines to be treated or <All>: " 
  ) 
  (or 
    (setq ss (ssget '((0 . "LWPOLYLINE")))) 
    (setq ss (ssget "_X" '((0 . "LWPOLYLINE")))) 
  ) 
  (if 
    ss 
     (progn 
       (vla-StartUndoMark *acdoc*) 
       (setq n -1) 
       (while (setq pl (ssname ss (setq n (1+ n)))) 
         (purge-pline pl) 
       ) 
       (princ (strcat "\n\t" (itoa n) " treated polyline(s).")) 
       (vla-EndUndoMark *acdoc*) 
     ) 
     (princ "\nNone selected polyline.") 
  ) 
  (princ) 
) 
(princ 
  "\nSimp-Pline loaded, type SPL to launch the function." 
) 
(princ)

dnbcgrass · 发表于 2017-5-11 16:53:13

回复一下、学习学习！

sh_h · 发表于 2017-5-11 22:59:55

谢谢楼主的分享！！！

ynhh · 发表于 2017-5-12 08:38:43

可消除多段线上直段中的中间控制点
谢谢大师的分享

yjch · 发表于 2017-5-12 09:01:32

好好学习天天向上，谢谢了

434939575 · 发表于 2017-5-12 12:03:16

这个太好了！谢谢分享！

434939575 · 发表于 2017-5-13 18:39:22

本帖最后由 434939575 于 2017-5-13 18:43 编辑

大师能修改为处理这种小折点不

，距离只有0.几毫米，合并为一个点.如果不在转角处(接近共线)就删除这个点。谢谢！

newer · 发表于 2017-5-13 18:47:30

434939575 发表于 2017-5-13 18:39

XDRX API 几行代码. 删除冗余点，动向段，删除极短段。

(defun c:tt ()
(if (and
(setq e (car (xdrx_entsel "\n拾取多段线<退出>:" '((0 . "LWPOLYLINE")))))
(setq tol (getreal "\n输入距离容差<退出>:"))
)
(progn
(xdrx_begin)
(xdrx_document_setprec tol 1.0)
(xdrx_polyline_compress e)
(xdrx_end)
)
)
(princ)
)

434939575 · 发表于 2017-5-13 18:52:45

newer 发表于 2017-5-13 18:47

感谢老大，这么快！

水夜轻 · 发表于 2022-9-27 16:32:39

老大，你这是三点完全在直线上的，如果三点夹角在一定角度内的都去除呢,比如178度，该怎么改啊？

杨89 · 发表于 2022-10-6 08:58:14

学习学习！

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

[每日一码] LWPOLYLINE清除冗余点，合并同向段

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