Author Topic: Remove extra Vertices from polyline  (Read 978 times)

0 Members and 1 Guest are viewing this topic.

PM

  • Guest
Remove extra Vertices from polyline
« on: December 08, 2022, 08:11:14 AM »
Hi. I am using this code to delete extra vetrices from polyline. I want to ask two things

1) Is it possible to select more than one polyline a time ?
2) I have  a drawing like the attach file with close polylines. I can not unerstand why some vertex not deleted. I want to keep only  the vertex at the edges of each polygon not on sections with 
    other ? Is any way to update the code to delete extra verteces on staight "line"?

Code - Auto/Visual Lisp: [Select]
  1.  
  2. (defun c:PSimple (/ doc ent elst vlst idx dir keep result hlst len
  3.                   group_on)
  4.  
  5.   ;; CAB 11/03/07
  6.   ;;  group on the elements of a flat list
  7.   ;;  (group_on '(A B C D E F G) 3)
  8.   ;;  Result  ((A B C) (D E F) (G nil nil)...)
  9.   (defun group_on (inplst gp# / outlst idx subLst)
  10.     (while inplst
  11.       (setq idx -1
  12.             subLst nil
  13.       )
  14.       (while (< (setq idx (1+ idx)) gp#)
  15.         (setq subLst (cons (nth idx inplst) sublst))
  16.       )
  17.       (setq outlst (cons (reverse sublst) outlst))
  18.       (repeat gp#
  19.         (setq inplst (cdr inplst))
  20.       )
  21.     )
  22.     (reverse outlst)
  23.   )
  24.  
  25.  
  26.   (setq ent (car (entsel "\n &#917;&#960;&#953;&#955;&#941;&#958;&#964;&#949; &#964;&#951;&#957; polyline &#947;&#953;&#945; &#948;&#953;&#945;&#947;&#961;&#945;&#966;&#942; &#964;&#969;&#957; extra vertex: ")))
  27.   (if (and ent
  28.            (setq elst (entget ent))
  29.            (equal (assoc 0 elst) '(0 . "LWPOLYLINE"))
  30.       )
  31.     (progn
  32.       (setq idx 0)
  33.         (cond
  34.           ((null keep)
  35.            (setq keep '(1)
  36.                  dir  (angle '(0 0) (vlax-curve-getFirstDeriv ent 0.0))
  37.            ))
  38.           ((or (null(vlax-curve-getFirstDeriv ent idx))
  39.                (equal dir (setq dir (angle '(0 0)
  40.                              (vlax-curve-getFirstDeriv ent idx))) 0.000001))
  41.            (setq keep (cons 0 keep))
  42.           )
  43.           ((setq keep (cons 1 keep)))
  44.         )
  45.         (setq idx (1+ idx))
  46.       )
  47.       (setq vlst (vl-remove-if-not
  48.                    '(lambda (x) (vl-position (car x) '(40 41 42 10))) elst))
  49.       (setq vlst (group_on vlst 4))
  50.       (setq idx -1
  51.             len (1- (length vlst))
  52.             keep (reverse (cons 1 keep))
  53.       )
  54.       (while (<= (setq idx (1+ idx)) len)
  55.         (cond
  56.           ((not (zerop (cdr(cadddr (nth idx vlst))))) ; keep arcs
  57.            (setq result (cons (nth idx vlst) result))
  58.           )
  59.           ((not (zerop (nth idx keep)))
  60.            (setq result (cons (nth idx vlst) result))
  61.           )
  62.         )
  63.       )
  64.  
  65.       (setq hlst (vl-remove-if
  66.                    '(lambda (x) (vl-position (car x) '(40 41 42 10))) elst))
  67.       (mapcar '(lambda(x) (setq hlst (append hlst x))) (reverse result))
  68.       (setq hlst (subst (cons 90 (length result)) (assoc 90 hlst) hlst))
  69.       (entmod hlst)
  70.     )
  71.   )
  72.  
  73.   (princ)
  74. )
  75.  
  76.  
  77.  

Thanks

ronjonp

  • Needs a day job
  • Posts: 7526
Re: Remove extra Vertices from polyline
« Reply #1 on: December 08, 2022, 09:36:30 AM »

Windows 11 x64 - AutoCAD /C3D 2023

Custom Build PC

PM

  • Guest
Re: Remove extra Vertices from polyline
« Reply #2 on: December 08, 2022, 10:57:41 AM »
Thanks ronjonp. This code works fine !!!

Code - Auto/Visual Lisp: [Select]
  1. ;; Purge-Pline (gile) 2007/11/25
  2. ;;
  3. ;; Removes all superfluous vertex (overwritten, colinear or concentric)
  4. ;; Keeps arcs and widths
  5. ;; Keeps aligne vertices which show a width break
  6. ;; Closes pline which start point and end point are overwritten
  7.  
  8. (defun purge-pline (pl        /         regular-width       colinear  concentric
  9.                     del-cadr  pour-car  elst      closed    old-p     old-b
  10.                     old-sw    old-ew    new-d     new-p     new-b     new-sw
  11.                     new-ew    b1        b2
  12.                    )
  13.  
  14.   ;; Evaluates if the pline width is regular on 3 successive points
  15.   (defun regular-width (p1 p2 p3 ws1 we1 ws2 we2 / delta)
  16.     (or (= ws1 we1 ws2 we2)
  17.         (and (= we1 ws2)
  18.              (/= 0 (setq delta (- we2 ws1)))
  19.              (equal (/ (- (vlax-curve-getDistAtPoint pl (trans p2 pl 0))
  20.                           (vlax-curve-getDistAtPoint pl (trans p1 pl 0))
  21.                        )
  22.                        (- (vlax-curve-getDistAtPoint pl (trans p3 pl 0))
  23.                           (vlax-curve-getDistAtPoint pl (trans p1 pl 0))
  24.                        )
  25.                     )
  26.                     (/ (- we1 (- we2 delta)) delta)
  27.                     1e-9
  28.              )
  29.         )
  30.     )
  31.   )
  32.  
  33.   ;; Evaluates if 3 successive vertices are aligned
  34.   (defun colinear (p1 p2 p3 b1 b2)
  35.     (and (zerop b1)
  36.         (zerop b2)
  37.         (null (inters p1 p2 p1 p3)
  38.         )
  39.     )
  40.   )
  41.  
  42.   ;; Evaluates if 3 sucessive vertices have the same center
  43.   (defun concentric (p1 p2 p3 b1 b2 / bd1 bd2)
  44.     (if
  45.       (and (/= 0.0 b1)
  46.            (/= 0.0 b2)
  47.            (equal
  48.              (caddr (setq bd1 (BulgeData b1 p1 p2)))
  49.              (caddr (setq bd2 (BulgeData b2 p2 p3)))
  50.              1e-9
  51.            )
  52.       )
  53.        (tan (/ (+ (car bd1) (car bd2)) 4.0))
  54.     )
  55.   )
  56.  
  57.   ;; Removes the second item of the list
  58.   (defun del-cadr (lst)
  59.     (set lst (cons (car (eval lst)) (cddr (eval lst))))
  60.   )
  61.  
  62.   ;; Pours the first item of a list to another one
  63.   (defun pour-car (from to)
  64.     (set to (cons (car (eval from)) (eval to)))
  65.     (set from (cdr (eval from)))
  66.   )
  67.  
  68.  
  69.   (setq elst (entget pl))
  70.   (and (= 1 (logand 1 (cdr (assoc 70 elst)))) (setq closed T))
  71.                       (cond
  72.                         ((= (car x) 10) (setq old-p (cons x old-p)))
  73.                         ((= (car x) 40) (setq old-sw (cons x old-sw)))
  74.                         ((= (car x) 41) (setq old-ew (cons x old-ew)))
  75.                         ((= (car x) 42) (setq old-b (cons x old-b)))
  76.                         (T (setq new-d (cons x new-d)))
  77.                       )
  78.                     )
  79.           )
  80.           elst
  81.   )
  82.                       (set l (reverse (eval l)))
  83.                     )
  84.           )
  85.           '(old-p old-sw old-ew old-b new-d)
  86.   )
  87.   (and closed (setq old-p (append old-p (list (car old-p)))))
  88.   (and (equal (cdar old-p) (cdr (last old-p)) 1e-9)
  89.        (setq closed T
  90.              new-d  (subst (cons 70 (Boole 7 (cdr (assoc 70 new-d)) 1))
  91.                            (assoc 70 new-d)
  92.                            new-d
  93.                     )
  94.        )
  95.   )
  96.   (while (cddr old-p)
  97.     (if (regular-width
  98.           (cdar old-p)
  99.           (cdadr old-p)
  100.           (cdaddr old-p)
  101.           (cdar old-sw)
  102.           (cdar old-ew)
  103.           (cdadr old-sw)
  104.           (cdadr old-ew)
  105.         )
  106.       (cond
  107.         ((colinear (cdar old-p)
  108.                    (cdadr old-p)
  109.                    (cdaddr old-p)
  110.                    (cdar old-b)
  111.                    (cdadr old-b)
  112.         )
  113.         (mapcar 'del-cadr '(old-p old-sw old-ew old-b))
  114.         )
  115.         ((setq bu (concentric
  116.                     (cdar old-p)
  117.                     (cdadr old-p)
  118.                     (cdaddr old-p)
  119.                     (cdar old-b)
  120.                     (cdadr old-b)
  121.                   )
  122.         )
  123.         (setq old-b (cons (cons 42 bu) (cddr old-b)))
  124.         (mapcar 'del-cadr '(old-p old-sw old-ew))
  125.         )
  126.         (T
  127.         (mapcar 'pour-car
  128.                 '(old-p old-sw old-ew old-b)
  129.                 '(new-p new-sw new-ew new-b)
  130.         )
  131.         )
  132.       )
  133.       (mapcar 'pour-car
  134.               '(old-p old-sw old-ew old-b)
  135.               '(new-p new-sw new-ew new-b)
  136.       )
  137.     )
  138.   )
  139.   (if closed
  140.     (setq new-p (reverse (cons (car old-p) new-p)))
  141.     (setq new-p (append (reverse new-p) old-p))
  142.   )
  143.   (mapcar
  144.     (function
  145.       (lambda (new old)
  146.         (set new (append (reverse (eval new)) (eval old)))
  147.       )
  148.     )
  149.     '(new-sw new-ew new-b)
  150.     '(old-sw old-ew old-b)
  151.   )
  152.   (if (and closed
  153.            (regular-width
  154.              (cdr (last new-p))
  155.              (cdar new-p)
  156.              (cdadr new-p)
  157.              (cdr (last new-sw))
  158.              (cdr (last new-ew))
  159.              (cdar new-sw)
  160.              (cdar new-ew)
  161.            )
  162.       )
  163.     (cond
  164.       ((colinear (cdr (last new-p))
  165.                 (cdar new-p)
  166.                 (cdadr new-p)
  167.                 (cdr (last new-b))
  168.                 (cdar new-b)
  169.        )
  170.        (mapcar (function (lambda (l)
  171.                            (set l (cdr (eval l)))
  172.                         )
  173.                )
  174.                '(new-p new-sw new-ew new-b)
  175.        )
  176.       )
  177.       ((setq bu (concentric
  178.                   (cdr (last new-p))
  179.                   (cdar new-p)
  180.                   (cdadr new-p)
  181.                   (cdr (last new-b))
  182.                   (cdar new-b)
  183.                 )
  184.        )
  185.        (setq new-b (cdr (reverse (cons (cons 42 bu) (cdr (reverse new-b))))))
  186.        (mapcar (function (lambda (l)
  187.                            (set l (cdr (eval l)))
  188.                         )
  189.                )
  190.                '(new-p new-sw new-ew)
  191.        )
  192.       )
  193.     )
  194.   )
  195.   (entmod
  196.     (append new-d
  197.             (apply 'append
  198.                    (apply 'mapcar
  199.                           (cons 'list (list new-p new-sw new-ew new-b))
  200.                    )
  201.             )
  202.     )
  203.   )
  204. )
  205.  
  206. ;; BulgeData Retourne les donnees d'un polyarc (angle rayon centre)
  207.  
  208. (defun BulgeData (bu p1 p2 / ang rad cen)
  209.   (setq ang (* 2 (atan bu))
  210.         rad (/ (distance p1 p2)
  211.                (* 2 (sin ang))
  212.             )
  213.         cen (polar p1
  214.                    (+ (angle p1 p2) (- (/ pi 2) ang))
  215.                    rad
  216.             )
  217.   )
  218.   (list (* ang 2.0) rad cen)
  219. )
  220.  
  221. ;; TAN Retourne la tangente de l'angle
  222.  
  223. (defun tan (ang)
  224.   (/ (sin ang) (cos ang))
  225. )
  226.  
  227. ;; SPL Calling function
  228.  
  229. (defun c:spl (/ ss n pl)
  230.   (or *acad* (setq *acad* (vlax-get-acad-object)))
  231.   (or *acdoc* (setq *acdoc* (vla-get-ActiveDocument *acad*)))
  232.   (princ
  233.     "\nSelect les polylines to be treated or <All>: "
  234.   )
  235.   (or
  236.     (setq ss (ssget '((0 . "LWPOLYLINE"))))
  237.     (setq ss (ssget "_X" '((0 . "LWPOLYLINE"))))
  238.   )
  239.   (if
  240.     ss
  241.      (progn
  242.        (vla-StartUndoMark *acdoc*)
  243.        (setq n -1)
  244.        (while (setq pl (ssname ss (setq n (1+ n))))
  245.         (purge-pline pl)
  246.        )
  247.        (princ (strcat "\n\t" (itoa n) " treated polyline(s)."))
  248.        (vla-EndUndoMark *acdoc*)
  249.      )
  250.      (princ "\nNone selected polyline.")
  251.   )
  252.   (princ)
  253. )
  254.  
  255.   "\nSimp-Pline loaded, type SPL to launch the function."
  256. )
  257.  


Crank

  • Water Moccasin
  • Posts: 1503
Re: Remove extra Vertices from polyline
« Reply #4 on: December 09, 2022, 01:13:54 PM »
Or use the OVERKILL command :-D .
Vault Professional 2023     +     AEC Collection

jvillarreal

  • Bull Frog
  • Posts: 332
Re: Remove extra Vertices from polyline
« Reply #5 on: December 09, 2022, 05:45:16 PM »
Or WEEDFEATURES if you have Civil 3D

mhupp

  • Bull Frog
  • Posts: 250
Re: Remove extra Vertices from polyline
« Reply #6 on: December 09, 2022, 10:26:34 PM »

MSTG007

  • Gator
  • Posts: 2598
  • I can't remeber what I already asked! I need help!
Re: Remove extra Vertices from polyline
« Reply #7 on: December 12, 2022, 07:51:34 AM »
piggy back on mhupp,
Civil3D you can use the Delete Elevation Point within the Ribbon. or the command: _AeccDeleteFeaturePI
Works with Feature Lines, 3D Polylines, and Polylines.
Civil3D 2020