Untested but this should work .. usage at the end:
;;; PLDIET.lsp [command name: PLD]
;;; To put lightweight PolyLines on a DIET (remove excess vertices); usually
;;; used for contours with too many too-closely-spaced vertices.
;;; Concept from PVD routine [posted on AutoCAD Customization Discussion
;;; Group by oompa_l, July 2009] by Brian Hailey, added to by CAB, and
;;; WEED and WEED2 routines by Skyler Mills at Cadalyst CAD Tips [older
;;; routines for "heavy" Polylines that won't work on newer lightweight ones];
;;; simplified in entity data list processing, and enhanced in other ways [error
;;; handling, default values, join collinear segments beyond max. distance,
;;; limit to current space/tab, account for change in direction across 0 degrees,
;;; option to keep or eliminate arc segments] by Kent Cooper, August 2009.
;;; Last edited 28 August 2013
;
(defun pld (*distmax* *cidmax* *arcstr* flag / *error* cmde disttemp cidtemp
arctemp plinc plsel pl pldata ucschanged front
10to42 vinc verts vert1 vert2 vert3
) ;
(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
(princ (strcat "\nError: " errmsg))
) ; end if
(if ucschanged
(command "_.ucs" "_prev")
) ; ^ i.e. don't go back unless routine reached UCS change but didn't change back
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
) ; end defun - *error*
;
(setq cmde (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_.undo" "_begin")
;;; (setq disttemp (getdist (strcat "\nMaximum distance between non-collinear vertices to straighten"
;;; (if *distmax*
;;; (strcat " <" (rtos *distmax* 2 2) ">")
;;; ""
;;; ) ; default only if not first use
;;; ": "
;;; ) ; end strcat
;;; ) ; end getdist & disttemp
;;; *distmax* (cond (disttemp) ; user entered number or picked distance
;;; (*distmax*) ; otherwise, user hit Enter - keep value
;;; ) ; end cond & *distmax*
;;; cidtemp (getangle (strcat "\nMaximum change in direction to straighten"
;;; (strcat
;;; ; offer prior choice if not first use; otherwise 15 degrees
;;; " <"
;;; (if *cidmax*
;;; (angtos *cidmax*)
;;; (angtos (/ pi 12))
;;; )
;;; ">"
;;; ) ; end strcat
;;; ": "
;;; ) ; end strcat
;;; ) ; end getdist & cidtemp
;;; *cidmax* (cond (cidtemp) ; user entered number or picked angle
;;; (*cidmax*) ; Enter with prior value set - use that
;;; ((/ pi 12)) ; otherwise [Enter on first use] - 15 degrees
;;; ) ; end cond & *cidmax*
;;; plinc 0 ; incrementer through selection set of Polylines
;;; ) ; end setq
;;; (initget "Retain Straighten")
;;; (setq arctemp (getkword (strcat "\nRetain or Straighten arc segments [R/S] <"
;;; (if *arcstr*
;;; (substr *arcstr* 1 1)
;;; "S"
;;; ) ; at first use, S default; otherwise, prior choice
;;; ">: "
;;; ) ; end strcat
;;; ) ; end getkword
;;; *arcstr* (cond (arctemp) ; if User typed something, use it
;;; (*arcstr*) ; if Enter and there's a prior choice, keep that
;;; ("Straighten") ; otherwise [Enter on first use], Straighten
;;; ) ; end cond & *arcstr*
;;; ) ; end setq
;;; ;
;;; (prompt "\nSelect LWPolylines to put on a diet, or press Enter to select all: ")
(if flag
(setq plsel (ssget "X" (list '(0 . "LWPOLYLINE") (cons 410 (getvar 'ctab)))))
(setq plsel (ssget '((0 . "LWPOLYLINE"))))
) ; end cond
(setq plsel (ssget "X" (list '(0 . "LWPOLYLINE") (cons 410 (getvar 'ctab))))) ;
(repeat (sslength plsel)
(setq pl (ssname plsel plinc))
(while (equal (vlax-curve-getstartpoint pl) (vlax-curve-getpointatparam pl 1) 1e-6)
; to correct for possibility that more than one vertices at beginning coincide,
; in which case Pline does not define a CS under UCS OBject, causing error
(command "_.pedit" pl "_edit" "_straighten" "" "" "_go" "_exit" "")
) ; while
(setq pldata (entget pl))
(if (/= (cdr (last pldata)) (trans '(0 0 1) 1 0)) ; extr. direction not parallel current CS
; for correct angle & distance calculations [projected onto current construction
; plane], since 10-code entries for LWPolylines are only 2D points:
(progn (command "_.ucs" "_new" "_object" pl) ; set UCS to match object
(setq ucschanged t) ; marker for *error* to reset UCS if routine doesn't
) ; end progn
) ; end if
(setq front ; list of "front end" [pre-vertices] entries, minus entity names & handle
(vl-remove-if
'(lambda (x) (member (car x) '(-1 330 5 10 40 41 42 210))) ; end lambda
pldata
) ; end removal & front
10to42 ; list of all code 10, 40, 41, 42 entries only
(vl-remove-if-not
'(lambda (x) (member (car x) '(10 40 41 42))) ; end lambda
pldata
) ; end removal & 10to42
vinc (/ (length 10to42) 4) ; incrementer for vertices within each Polyline
verts nil ; eliminate from previous Polyline [if any]
) ; end setq
(if (= *arcstr* "Straighten")
(progn (setq bulges ; find any bulge factors
(vl-remove-if-not
'(lambda (x)
(and (= (car x) 42) (/= (cdr x) 0.0)) ; end and
) ; end lambda
10to42
) ; end removal & bulges
) ; end setq
(foreach x bulges (setq 10to42 (subst '(42 . 0.0) x 10to42)))
; straighten all arc segments to line segments
) ; end progn
) ; end if
(repeat vinc
(setq verts ; sub-group list: separate list of four entries for each vertex
(cons (list (nth (- (* vinc 4) 4) 10to42)
(nth (- (* vinc 4) 3) 10to42)
(nth (- (* vinc 4) 2) 10to42)
(nth (1- (* vinc 4)) 10to42)
) ; end list
verts
) ; end cons & verts
vinc (1- vinc) ; will be 0 at end
) ; end setq
) ; end repeat
(while (nth (+ vinc 2) verts) ; still at least 2 more vertices
(if (or ; only possible if chose to Retain arc segments
(/= (cdr (assoc 42 (nth vinc verts))) 0.0) ; next segment is arc
(/= (cdr (assoc 42 (nth (1+ vinc) verts))) 0.0) ; following segment is arc
) ; end or
(setq vinc (1+ vinc)) ; then - don't straighten from here; move to next
(progn ; else - analyze from current vertex
(setq vert1 (cdar (nth vinc verts)) ; point-list location of current vertex
vert2 (cdar (nth (1+ vinc) verts)) ; of next one
vert3 (cdar (nth (+ vinc 2) verts)) ; of one after that
ang1 (angle vert1 vert2)
ang2 (angle vert2 vert3)
) ; end setq
(if (or (equal ang1 ang2 0.0001) ; collinear, ignoring distance
(and (<= (distance vert1 vert3) *distmax*)
; straightens if direct distance from current vertex to two vertices later is
; less than or equal to maximum; if preferred to compare distance along
; Polyline through intermediate vertex, replace above line with this:
; (<= (+ (distance vert1 vert2) (distance vert2 vert3)) *distmax*)
(<= (if (> (abs (- ang1 ang2)) pi) ; if difference > 180 degrees
(+ (min ang1 ang2) (- (* pi 2) (max ang1 ang2)))
; then - compensate for change in direction crossing 0 degrees
(abs (- ang1 ang2)) ; else - size of difference
) ; end if
*cidmax*
) ; end <=
) ; end and
) ; end or
(setq verts (vl-remove (nth (1+ vinc) verts) verts))
; then - remove next vertext, stay at current vertex for next comparison
(setq vinc (1+ vinc)) ; else - leave next vertex, move to it as new base
) ; end if - distance & change in direction analysis
) ; end progn - line segments
) ; end if - arc segment check
) ; end while - working through vertices
(setq front (subst (cons 90 (length verts)) (assoc 90 front) front)
; update quantity of vertices for front end
10to42 nil ; clear original set
) ; end setq
(foreach x verts (setq 10to42 (append 10to42 x)))
; un-group four-list vertex sub-lists back to one list of all 10, 40, 41, 42 entries
(setq pldata (append front 10to42 (list (last pldata))))
; put front end, vertex entries and extrusion direction back together
(entmake pldata)
(entdel pl) ; remove original
(setq plinc (1+ plinc)) ; go on to next Polyline
(if ucschanged
(progn (command "_.ucs" "_prev")
(setq ucschanged nil) ; eliminate UCS reset in *error* since routine did it already
) ; end progn
) ; end if - UCS reset
) ; end repeat - stepping through set of Polylines
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
(princ)
) ; end defun - PLD
(prompt "\nType PLD to put PolyLines on a Diet.")
;; Usage
;; (pld 10000000000000000 2 "Retain" T)
