多段线PURGE（删除冗余顶点，重叠，共线段）

Lisphk · 发表于 2018-3-17 15:42:51

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

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

×

;; 删除所有多余的顶点（重叠，共线或同心）
;; 保持弧度和宽度
;; 保持显示宽度中断的顶点
;; 封闭起点和终点重叠的pline

;; 删除所有多余的顶点（重叠，共线或同心）
;; 保持弧度和宽度
;; 保持显示宽度中断的顶点
;; 封闭起点和终点重叠的pline
(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)
)
)
)
;; 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)

;; 删除所有多余的顶点（重叠，共线或同心） 
;; 保持弧度和宽度 
;; 保持显示宽度中断的顶点 
;; 封闭起点和终点重叠的pline 
 
(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) 
         ) 
    ) 
  ) 
  ;; 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)

需要的函数：

游客，如果您要查看本帖隐藏内容请回复

sh_h · 发表于 2018-3-19 09:40:05

回复学习，谢谢了！

q3_2006 · 发表于 2018-3-17 15:50:40

感觉之前看过一样的帖子..

scnjlwb · 发表于 2018-3-17 19:45:19

谢谢分享！

cable2004 · 发表于 2018-3-17 22:13:57

谢谢分享！

Havis · 发表于 2018-3-18 09:08:47

谢谢分享！

HLCAD · 发表于 2018-3-18 10:19:16

感谢大师给我们提供了一个非常实用的功能！

小陶 · 发表于 2018-3-18 12:45:09

看看大师作品！

liunian0524 · 发表于 2018-3-18 14:56:08

感谢大师分享

zjy2999 · 发表于 2018-3-19 08:36:42

xuexi！！！！！！！！！！！！！！！！！！

zyclyl · 发表于 2018-3-19 08:47:12

厉害呀！！！！

liulisheng · 发表于 2018-3-19 08:49:55

支持一下哦

yoyoho · 发表于 2018-3-19 09:54:27

回复学习，谢谢了！

小菜 · 发表于 2018-3-19 11:32:16

谢谢分享！

evayleung · 发表于 2018-3-19 18:49:04

谢谢，支持一下。。。。

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

[每日一码] 多段线PURGE（删除冗余顶点，重叠，共线段）

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

评分