I don't know is it working, but at least I've sorted and cleaned up the code not to look like you wrote it with legs, but with typing with hands...
;; ;;
;; -------------=={ Trim Outside Points LWPolyline Section }==--------------;;
;; https://www.theswamp.org/index.php?topic=57031.msg606331#msg606331 ;;
;; removes segment(s) from End to Start -> ;;
;; This altered program prompts the user to pick points and TRIM ;;
;; selected LWPolyline. The user is then prompted to specify two ;;
;; POINTS on the LWPolyline enclosing the section to be kept. The ;;
;; program will proceed to erase all segments outside, after *ES* the ;;
;; two given points to BOTH sides by the specified distance. ;;
;; ;;
;; The program is compatible with LWPolylines of constant or varying ;;
;; width, with straight and/or arc segments, and defined in any UCS ;;
;; construction plane. ;;
;;----------------------------------------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2013 - www.lee-mac.com ;;
;;-----------------------------------------------------------------------------------------------;;
(defun c:top ( / *error* selfinters clockwise-p v^v tan LM:lwvertices sdd cosm ss d e h l m n o p q w x z )
;;(princ "\n Direction of Trim/Remove..\n [CCW: north or west.. CW: south or east] < - / = to change>")
;;(princ "\n Trim/Remove Segments from Points..<SD>")
(vl-load-com)
(defun *error* ( m )
(if cosm
(setvar 'osmode cosm)
)
(if m
(prompt m)
)
(princ)
)
(setq cosm (getvar 'osmode))
(setvar 'osmode 7039)
;;--------------------------------------------------------------------------------------------
;; direction arrow tool
(defun selfinters ( o / a )
(or
(vl-catch-all-error-p
(setq a (vl-catch-all-apply 'vlax-invoke (list ms 'addregion (list o))))
)
(vla-delete (car a))
)
)
(defun clockwise-p ( e / p1 p2 p a b d f1 f2 )
(vla-getBoundingBox (vlax-ename->vla-object e) 'p1 'p2)
(setq p
(vlax-curve-getparamatpoint e
(vlax-curve-getclosestpointtoprojection e
(mapcar '- (vlax-safearray->list p1) '(1 1 0))
'(1 0 0)
)
)
a (vlax-curve-getstartparam e)
b (vlax-curve-getendparam e)
d (if
(eq (cdr (assoc 0 (entget e))) "SPLINE")
(* 0.01 (- b a))
0.1
)
f1 (vlax-curve-getfirstderiv e (+ a (rem (+ p d) (- b a))))
f2 (vlax-curve-getfirstderiv e (+ a (rem (+ (- p d) (- b a)) (- b a))))
)
(minusp (caddr (v^v f2 f1)))
)
(defun v^v ( a b )
(list
(- (* (cadr a) (caddr b)) (* (caddr a) (cadr b)))
(- (* (caddr a) (car b)) (* (car a) (caddr b)))
(- (* (car a) (cadr b)) (* (cadr a) (car b)))
)
)
;; Tangent - Lee Mac
;; Args: x - real
(defun tan ( x )
(if (not (equal 0.0 (cos x) 1e-8))
(/ (sin x) (cos x))
)
)
;; LW Vertices - Lee Mac
;; Returns a list of lists in which each sublist describes the position,
;; starting width, ending width and bulge of a vertex of an LWPolyline
(defun LM:lwvertices ( e )
(if (setq e (member (assoc 10 e) e))
(cons
(list
(assoc 10 e)
(assoc 40 e)
(assoc 41 e)
(assoc 42 e)
)
(LM:lwvertices (cdr e))
)
)
)
(defun sdd ( ss / h i e c s f j d r p a )
(if ss
(progn
(setq h (* 0.03 (getvar 'viewsize)))
(repeat (setq i (sslength ss))
(setq e (ssname ss (setq i (1- i)))
c (cond ( (and ;arrows color
(vlax-curve-isplanar e)
(vlax-curve-isclosed e)
(not (selfinters (vlax-ename->vla-object e)))
)
(if (clockwise-p e) 1 3) ; ;green if was clockwise, red if not
)
( (if (< (car (vlax-curve-getstartpoint e)) (car (vlax-curve-getendpoint e))) 1 3)
)
)
)
(cond
( (and e (wcmatch (cdr (assoc 0 (entget e))) "LINE,SPLINE,ARC,ELLIPSE,CIRCLE,HELIX"))
(setq s (vlax-curve-getstartparam e) ;start curve
f (vlax-curve-getendparam e)
j 10 ;10 arrows on a single spline
d (/ (- f s) j) ;segment "length" (in paramter units)
)
)
( (and e (wcmatch (cdr (assoc 0 (entget e))) "*POLYLINE"))
(setq s 0.0
j (fix (vlax-curve-getendparam e)) ;1 arrow per segment for polylines
d 1.0
)
)
)
(if e
(repeat j
(setq j (1- j)
r (+ s (* j d) (* 0.5 d)) ;current parameter
p (vlax-curve-getpointatparam e r)
a ( (lambda ( d ) (atan (cadr d) (car d))) (vlax-curve-getfirstderiv e r) )
)
(grdraw p (polar p (+ a (* pi 0.9)) h) c)
(grdraw p (polar p (- a (* pi 0.9)) h) c)
)
)
)
)
)
)
;;-----------------------------------------------------------------------------
;; main program
(prompt "\nESC to FINISH...")
(while (not (vl-catch-all-error-p (vl-catch-all-apply 'grread (list t 15 0))))
(if (setq ss (ssget "_A" '((0 . "*POLYLINE,SPLINE,LINE,ARC,ELLIPSE,CIRCLE,HELIX"))))
(sdd ss)
)
(setvar 'errno 0)
(setq e (car (entsel "\nSelect LWPolyline: ")))
(cond
( (= 7 (getvar 'errno))
(princ "\nMissed, try again.")
)
( (null e) nil)
( (/= "LWPOLYLINE" (cdr (assoc 0 (entget e))))
(princ "\nObject is Not a LWPolyline.")
)
( (setq p (getpoint "\nSpecify 1st Point: "))
(setq p (vlax-curve-getclosestpointto e (trans p 1 0)))
(while
(and
(setq q (getpoint (trans p 0 1) "\nSpecify 2nd Point: "))
(equal p (setq q (vlax-curve-getclosestpointto e (trans q 1 0))) 1e-8)
)
(princ "\nPoints Must be Distinct.")
)
(if q
(progn
(if (> (setq m (vlax-curve-getparamatpoint e p))
(setq n (vlax-curve-getparamatpoint e q))
)
(mapcar 'set '(m n p q) (list n m q p))
)
(setq e (entget e)
h (cond ( (reverse (member (assoc 39 e) (reverse e))) ) ( (reverse (member (assoc 38 e) (reverse e))) ))
h (subst (cons 70 (logand (cdr (assoc 70 h)) (~ 1))) (assoc 70 h) h)
l (LM:lwvertices e)
z (assoc 210 e)
)
(repeat (fix m)
(setq l (cdr l))
)
(if (not (equal m (fix m) 1e-8))
(setq x (car l)
w (cdr (assoc 40 x))
l
(cons
(list
(cons 10 (trans p 0 (cdr z)))
(cons 40 (+ w (* (- m (fix m)) (- (cdr (assoc 41 x)) w))))
(assoc 41 x)
(cons 42
(tan
(* (- (min n (1+ (fix m))) m)
(atan (cdr (assoc 42 x)))
)
)
)
)
(cdr l)
)
)
)
(setq l (reverse l))
(repeat (+ (length l) (fix m) (- (fix n)) -1)
(setq l (cdr l))
)
(if (not (equal n (fix n) 1e-8))
(setq x (car l)
w (cdr (assoc 40 x))
l
(vl-list*
(list
(cons 10 (trans q 0 (cdr z)))
'(40 . 0.0)
'(41 . 0.0)
'(42 . 0.0)
)
(list
(assoc 10 x)
(assoc 40 x)
(cons 41
(+ w
(* (/ (- n (max m (fix n))) (- (1+ (fix n)) (max m (fix n))))
(- (cdr (assoc 41 x)) w)
)
)
)
(cons 42
(tan
(* (if (< (fix n) m) 1.0 (- n (fix n)))
(atan (cdr (assoc 42 x)))
)
)
)
)
(cdr l)
)
)
)
(setq o
(vlax-ename->vla-object
(entmakex (append h (apply 'append (reverse l)) (list z)))
)
)
(entdel (cdr (assoc -1 e)))
)
)
)
)
(redraw)
)
(*error* nil)
)
M.R.
