Polyline Cleanup - Preserving Start/End Widths

[hamza_itani]

This LISP removes zero-length segments from polylines. However, it's currently stripping the widths. Looking for help to modify it to retain the original polyline start and end widths. Thanks!

(vl-load-com)

(defun c:zlp (/ ss i ent exploded_ss exploded_ent len zero_length_count)
  ;; Initialize a counter for zero-length segments
  (setq zero_length_count 0)

  ;; Get the ActiveDocument object for VBA Undo
  (setq acadDocument (vla-get-ActiveDocument (vlax-get-acad-object)))

  ;; Start undo mark here
  (vla-startundomark acadDocument)

  (setvar 'cmdecho 0) ; Turn command echo off for cleaner execution

  ;; Get polylines selection
  (princ "\nSelect polylines to process: ")
  (setq ss (ssget '((0 . "LWPOLYLINE"))))
  (if ss
    (progn
      (setvar 'peditaccept 1) ; Set PEDITACCEPT to 1 to avoid prompts
      (setq i 0)
      (repeat (sslength ss)
        (setq ent (ssname ss i))
        (setq i (1+ i)) ; Increment counter for next polyline

        ;; Explode the current polyline
        (command "_.explode" ent)

        ;; Get the exploded parts (previous selection) immediately after explode
        (setq exploded_ss (ssget "P"))

        ;; Delete zero-length parts
        (if exploded_ss
          (progn
            (setq j 0)
            (repeat (sslength exploded_ss)
              (setq exploded_ent (ssname exploded_ss j))
              (setq j (1+ j))

              ;; Check for zero length (using vlax-curve-getdistatparam for lines/arcs)
              (if (or (= (cdr (assoc 0 (entget exploded_ent))) "LINE")
                      (= (cdr (assoc 0 (entget exploded_ent))) "ARC")
                      (= (cdr (assoc 0 (entget exploded_ent))) "LWPOLYLINE") ; in case explode results in polyline segments
                  )
                (progn
                  (setq len (vlax-curve-getdistatparam exploded_ent (vlax-curve-getendparam exploded_ent)))
                  (if (< len 1e-6) ; Tolerance for zero length
                    (progn
                      ;; Increment the zero_length_count before deleting
                      (setq zero_length_count (1+ zero_length_count))
                      (entdel exploded_ent) ; Delete zero-length entity
                    )
                  )
                )
              )
            )
          )
        )

        ;; Rejoin the exploded parts back into a polyline
        (if exploded_ss
          (command "_.pedit" "_multiple" exploded_ss "" "_join" "" "")
        )

      ) ; repeat for each polyline

      ;; Report the total number of deleted zero-length segments
      (if (> zero_length_count 0)
        (princ (strcat "\nPolylines processed and " (itoa zero_length_count) " zero-length segments removed."))
        (princ "\nPolylines processed. No zero-length segments were removed.")
      )
    )
    (princ "\nNo polylines selected.")
  )

  (setvar 'cmdecho 1) ; Turn command echo back on

  ;; End undo mark
  (vla-endundomark acadDocument)

  (princ)
)

[paullimapa]

This thread should provide you the answer so you can modify the code on your own

https://forums.autodesk.com/t5/autocad-lt-forum/get-the-global-width-of-a-polyline-on-selection-with...

[Moshe-A]

@hamza_itani hi,

before explode, save start/ end width and apply it after join

(setq elist (entget ent))
(setq w0 (cdr (assoc '40 elist)))
(setq w1 (cdr (assoc '41 elist)))

[Kent1Cooper]

---

@hamza_itani wrote:

... it's currently stripping the widths. ....

---

Since you use the plural, are you talking about Polylines with varying width?  Other suggestions so far seem to be about global width.

[hamza_itani · Accepted solution]

@Kent1Cooper Yes, the widths vary.

@paullimapa @Moshe-A  Thanks for the pointers.

I put this together, do you think it's okay now?

;; getMaxPolylineWidth by ronjonp:
;; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/set-global-width-of-polyline-from-exising-pline/m-p/8691618/highlight/true#M383138

(vl-load-com)

(defun getMaxPolylineWidth (polyline_ent / b)
  (if (= "LWPOLYLINE" (cdr (assoc 0 (setq b (entget polyline_ent)))))
    (cond
      ((cdr (assoc 43 b))) ; Constant width
      ((apply 'max
              (mapcar 'cdr (vl-remove-if-not '(lambda (x) (member (car x) '(40 41))) b))
      )) ; Fattest width from segments
      (0.0) ; Default to 0 if no width info found
    )
    0.0 ; Return 0 if not a polyline
  )
)

(defun c:zlp (/ ss i ent exploded_ss exploded_ent len zero_length_count maxWidth rejoined_ss rejoined_polyline)
  ;; Initialize a counter for zero-length segments
  (setq zero_length_count 0)

  ;; Get the ActiveDocument object for VBA Undo
  (setq acadDocument (vla-get-ActiveDocument (vlax-get-acad-object)))

  ;; Start undo mark here
  (vla-startundomark acadDocument)

  (setvar 'cmdecho 0) ; Turn command echo off for cleaner execution

  ;; Get polylines selection
  (princ "\nSelect polylines to process: ")
  (setq ss (ssget '((0 . "LWPOLYLINE"))))
  (if ss
    (progn
      (setvar 'peditaccept 1) ; Set PEDITACCEPT to 1 to avoid prompts
      (setq i 0)
      (repeat (sslength ss)
        (setq ent (ssname ss i))
        (setq i (1+ i)) ; Increment counter for next polyline

        ;; Get max width before explode
        (setq maxWidth (getMaxPolylineWidth ent))

        ;; Explode the current polyline
        (command "_.explode" ent)

        ;; Get the exploded parts (previous selection) immediately after explode
        (setq exploded_ss (ssget "P"))

        ;; Delete zero-length parts
        (if exploded_ss
          (progn
            (setq j 0)
            (repeat (sslength exploded_ss)
              (setq exploded_ent (ssname exploded_ss j))
              (setq j (1+ j))

              ;; Check for zero length (using vlax-curve-getdistatparam for lines/arcs)
              (if (or (= (cdr (assoc 0 (entget exploded_ent))) "LINE")
                      (= (cdr (assoc 0 (entget exploded_ent))) "ARC")
                      (= (cdr (assoc 0 (entget exploded_ent))) "LWPOLYLINE") ; in case explode results in polyline segments
                  )
                (progn
                  (setq len (vlax-curve-getdistatparam exploded_ent (vlax-curve-getendparam exploded_ent)))

            ;;    (if (< len 1e-6) ; Tolerance for zero length

                  (if (= len 0.0) ; Check for absolute zero length
                    (progn
                      ;; Increment the zero_length_count before deleting
                      (setq zero_length_count (1+ zero_length_count))
                      (entdel exploded_ent) ; Delete zero-length entity
                    )
                  )
                )
              )
            )
          )
        )

        ;; Rejoin the exploded parts back into a polyline
        (if exploded_ss
          (progn
            (command "_.pedit" "_multiple" exploded_ss "" "_join" "" "")
            ;; Get the last created polyline (rejoined one)
            (setq rejoined_ss (ssget "L"))
            (if rejoined_ss
              (setq rejoined_polyline (ssname rejoined_ss 0))
              (setq rejoined_polyline nil) ; Handle case where no entity is selected (rejoin failed?)
            )
            (if rejoined_polyline
              (command "_.pedit" rejoined_polyline "width" maxWidth "")
            )
          )
        )

      ) ; repeat for each polyline

      ;; Report the total number of deleted zero-length segments
      (if (> zero_length_count 0)
        (princ (strcat "\nPolylines processed and " (itoa zero_length_count) " zero-length segments removed."))
        (princ "\nPolylines processed. No zero-length segments were removed.")
      )
    )
    (princ "\nNo polylines selected.")
  )

  (setvar 'cmdecho 1) ; Turn command echo back on

  ;; End undo mark
  (vla-endundomark acadDocument)

  (princ)
)
(princ)

[paullimapa]

Looks pretty good. Of course if there were varying pline segment widths prior to explode afterwards you’ll end up with a single maximum width for the rejoined pline. 

[Kent1Cooper]

Look at PolylineSubDivide.lsp [PSD command], >here<, which breaks a Polyline into separate single-segment Polylines, preserving all width(s).  Interestingly, if used on a Polyline containing zero-length segments, those don't become zero-length single-segment ones, but they simply disappear.  Then regular JOIN or PEDIT / Multiple / Join will put what remains back together, all widths are preserved, and the zero-length segments are gone.  I suppose it would be possible to make a routine that does the PSD and then the JOIN, all in one.

[Moshe-A]

@hamza_itani  hi,

Check my version, Command EPSZ (Eliminate Pline Zero Segments)

at start of program on line #40

(setq FUZZ 1e-3) ; const

this equal to 0.001 and this is the amount of distance 2 successive nodes would be consider as zero segment. you might want to increase this to also eliminate bigger gaps.

this program takes in consideration that a pline may have more than 2 successive zero segments and continue to loop until no zero segments is found.

the pline points update is done through ActiveX so the the other properties is left intact (including width 😀).

enjoy

Moshe

; eliminate pline zero segments

(defun c:epzs (/ _geometric _process _doubles ; local function
	         FUZZ ctr ss ename data^ points^ sa var AcDbPline)

 ; anonumous function
 (setq _geometric (lambda (ent) (vl-remove-if 'not (mapcar (function (lambda (item) (if (= (car item) 10) (cdr item)))) (entget ent)))))

  
 (defun _process (lst Qctr)
  (append
   (vl-remove-if
    'not
     (mapcar
      (function
       (lambda (t0 t1)
        (if (equal (distance t0 t1) 0.0 FUZZ)
         (not (set Qctr (1+ (vl-symbol-value Qctr)))) ; indirect set, make sure nil returns here
         t0
        ); if
       ); lambda
      ); function
      (reverse (cdr (reverse lst))) (cdr lst)	
     ); mapcar
    ); vl-remove-if
    (list (last lst))
  ); append
 ); _process

  
 (defun _doubles (pts^ / pt lst)
  (foreach pt pts^
   (setq lst (cons (cadr pt) (cons (car pt) lst)))
  )
  (reverse lst) 
 ); _doubles


 ; here start c:epzs
 (setq FUZZ 1e-3) ; const
 (setq ctr 1)
  
 (if (setq ss (ssget '((0 . "lwpolyline"))))
  (foreach ename (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
   (while (> ctr 0)  	; process until no zero segments found
    (setq ctr 0)	; reset counter
    (setq data^ (_geometric ename))
    (setq points^ (_process data^ 'ctr)) ; ctr is incremented in the calling function
     
    ; update pline only if zero segments found
    (if (< (vl-list-length points^) (vl-list-length data^)) 
     (progn 
      (setq sa (vlax-make-safearray vlax-vbDouble (cons '0 (1- (* 2 (vl-list-length points^))))))
      (vlax-safearray-fill sa (_doubles points^))
      (setq var (vlax-make-variant sa))
      (setq AcDbPline (vlax-ename->vla-object ename))
      (vla-put-coordinates AcDbPline var) ; update pline
      (vlax-release-object AcDbPline)
     ); progn
    ); if
   ); while
  ); foreach
 ); if

 (princ) 
); c:epzs

[TomBeauford]

You could just use the OVERKILL (Command) to delete zero-length polyline segments.

[hamza_itani]

@Kent1Cooper 
The PSD Command Doesn't remove all zero-length lines, see attached Screenshot + DWG.

[hamza_itani]

@Moshe-A 

EPZS Command causes deformations for some polylines, it was the main reason I started this thread, see HERE.

[hamza_itani]

@TomBeauford 

EDIT: sorry, I thought it works, but my use case is adding Vertex to polyline segments which are longer than X, overkill removes all these vertex which it considers unnecessary. That's why OVERKILL doesn't do the job.

[hamza_itani]

Thanks all, I'm satisfied with ZLP command I posted above, always new things to learn.

[Kent1Cooper]

---

@hamza_itani wrote:

The PSD Command Doesn't remove all zero-length lines, see attached Screenshot + DWG.

---

I had tested it on intermediate zero-length segments, and [for me] it does remove those in your drawing.  You're right, it doesn't remove one when it's at the end.  I could try to figure out why, but that's not part of the purpose of the routine, and there are other solutions here.

I did find that in one of yours, a simple REVERSE eliminated the zero-length end segment, but not in another one -- I don't know why.