Create a new polyline from two on a path of a Polyline

[mhy3sx]

Hi, I am trying to convert this code.  This code ask to select two points  of a polyline and draw a polyline on the path of the previous polyline to connect them. The problem is that this code connect the two points the most of the time, not from the side I want. I want to add somehow  an option , for example  Pick from the side you  want to create the Polyline. Can any one help?

 

 

;PLP - Copying part of LWPolyline
;Lay y tuong tu https://www.cadtutor.net/forum/topic/77002-coping-part-of-polyline/#comment-614215
;Copy from Lee-Mac http://lee-mac.com/offsetpolysection.html

;;------------------=={ Offset LWPolyline Section }==-------------------;;
;;                                                                      ;;
;;  This program prompts the user to specify an offset distance and to  ;;
;;  select an LWPolyline. The user is then prompted to specify two      ;;
;;  points on the LWPolyline enclosing the section to be offset. The    ;;
;;  progam will proceed to offset all segments between 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              ;;
;;----------------------------------------------------------------------;;
;;  Version 1.0    -    27-12-2012                                      ;;
;;                                                                      ;;
;;  First release.                                                      ;;
;;----------------------------------------------------------------------;;
;;  Version 1.1    -    05-04-2013                                      ;;
;;                                                                      ;;
;;  Fixed bug when offsetting polyline arc segments.                    ;;
;;----------------------------------------------------------------------;;

(defun c:PLP ( / d e h l m n o p q w x z elast tt)
  (vl-load-com)
  
    ;; Check if the layer exists, if not, create it
  (if (not (tblsearch "LAYER" "Poly"))
	(command "_layer" "_m" "Poly" "_c" "10" "" "_lw" "0.70" "" "plot" "no" "" "")
  )

;Sub-Function----------------------------------------------------------------------
  
;; 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))
        )
    )
)
;Sub-Function----------------------------------------------------------------------

;Main-Function---------------------------------------------------------------------
  (setq PLP-Type (if (and PLP-Type
			(= (type PLP-Type) 'STR)
			(or (= PLP-Type "Entsel")
			    (= PLP-Type "NEntsel")))
		 PLP-Type
		 "Entsel"))
  (setq d 1
	elast (entlast)
	tt T)
  
  (while tt
    (setvar 'errno 0)
    (initget "Entsel NEntsel")
    (if (= PLP-Type "Entsel")
      (setq e (entsel (strcat "\nEntsel. Copying part of LWPolyline. Select LWPolyline [Entsel/NEntsel]: ")))
      (setq e (nentsel (strcat "\nNEntsel. Copying part of LWPolyline. Select LWPolyline [Entsel/NEntsel]: "))))
    (if e
      (progn
	(if (= e "Entsel")(setq PLP-Type "Entsel"))
	(if (= e "NEntsel")(setq PLP-Type "NEntsel"))
	(if (and
	      (= (type e) 'LIST)
	      (= (type (car e)) 'ENAME))
	  (progn
	    (setq e (car e))
	    (sssetfirst (ssadd e (ssadd))(ssadd e (ssadd)))
	    (cond
                (   (= 7 (getvar 'errno))
                    (princ "\nMissed, try again.")
                )
                (   (null e) nil)
                (   (/= "LWPOLYLINE" (cdr (assoc 0 (entget e))))
                    (princ (strcat "\nObject " (cdr (assoc 0 (entget e))) " 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 (reverse (member (assoc 39 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)
                                    )
                                )
                            )
							  ;; After creating the polyline
                            (setq o
                                (vlax-ename->vla-object
                                    (entmakex (append h (apply 'append (reverse l)) (list z)))
                                )
							 ;; Set the layer of the polyline to "Poly"
                            )
							(vla-put-Layer o "Poly")
                            ;(vl-catch-all-apply 'vla-offset (list o d))
                            ;(vl-catch-all-apply 'vla-offset (list o (- d)))
                            ;(vla-delete o)
                        )
                    )
                )
            );cond
	    );progn
	  );if
	);progn
      (setq tt nil));if
    (if (> (sslength (ssadd (entlast)(ssadd elast (ssadd)))) 1);created new pline
      (progn
	(sssetfirst (ssadd (entlast)(ssadd))(ssadd (entlast)(ssadd)))
	(setq tt nil)))
    );while
  (princ)
);defun
;;----------------------------------------------------------------------;;
;;                             End of File                              ;;
;;----------------------------------------------------------------------;;

 

 

Thanks

[mhy3sx]

Is it possible to add a Specify 3nd Point to select the correct side to draw the polyline?

 

Thanks

[marko_ribar]

Have you tried Plpath.lsp from here : https://www.cadtutor.net/forum/topic/37726-draw-polyline-along-with-2-or-more-adjacent-closed-polylines/?do=findComment&comment=442693

 

I think that it have option top or bottom - 2 sides, but it's not working with 3rd point... So you'll have to try and retry if it's wrong way...

[mhy3sx]

Thanks marko_ribar , I didn't  know about this code !!! is nice

 

Thanks

[mhy3sx]

Marko_ribar  I  want to ask a question about Plpath.lsp. Some times I select the option Top but draw the line Bottom. How the code undestand the Top or the Bottom?

 

All my polylines are CCW. The Top / Bottom is not working well. Is better if I had an option to pick the side.

 

(defun c:PlPath ( / rlw AssocOn ListClockwise-p MR:GetVertices MR:GetBulge _intl prelst suflst _Buildlist
                   loop sp ep ss opt i pl hpllst rpllst pll a b bb ab lst lstab Pls Bls PtlSt PtBulg PttBulg )

 (vl-load-com)

 (defun rlw (LW / E X1 X2 X3 X4 X5 X6)
   ;; by ElpanovEvgeniy
   ;; reverse lwpolyline
   (if (= (cdr (assoc 0 (setq e (entget lw)))) "LWPOLYLINE")
     (progn (foreach a1 e
              (cond ((= (car a1) 10) (setq x2 (cons a1 x2)))
                    ((= (car a1) 40) (setq x4 (cons (cons 41 (cdr a1)) x4)))
                    ((= (car a1) 41) (setq x3 (cons (cons 40 (cdr a1)) x3)))
                    ((= (car a1) 42) (setq x5 (cons (cons 42 (- (cdr a1))) x5)))
                    ((= (car a1) 210) (setq x6 (cons a1 x6)))
                    (t (setq x1 (cons a1 x1)))
              )
            )
            (entmod (append (reverse x1)
                            (append (apply (function append)
                                           (apply (function mapcar)
                                                  (cons 'list
                                                        (list x2
                                                              (cdr (reverse (cons (car x3) (reverse x3))))
                                                              (cdr (reverse (cons (car x4) (reverse x4))))
                                                              (cdr (reverse (cons (car x5) (reverse x5))))
                                                        )
                                                  )
                                           )
                                    )
                                    x6
                            )
                    )
            )
            (entupd lw)
     )
   )
 )
 
 (defun AssocOn ( SearchTerm Lst func fuzz )
   (car
     (vl-member-if
       (function
         (lambda (pair) (equal SearchTerm (apply func (list pair)) fuzz))
       )
       lst
     )
   )
 )
 
 (defun ListClockwise-p ( lst / z vlst )
   (vl-catch-all-apply 'minusp 
     (list
       (if 
         (not 
           (equal 0.0
             (setq z
               (apply '+
                 (mapcar 
                   (function
                     (lambda (u v)
                       (- (* (car  u) (cadr  v)) (* (car  v) (cadr  u)))
                     )
                   )
                   (setq vlst
                     (mapcar
                       (function
                         (lambda (a b) (mapcar '- b a))
                       )
                       (mapcar (function (lambda (x) (car lst))) lst) 
                       (cdr (reverse (cons (car lst) (reverse lst))))
                     )
                   )
                   (cdr (reverse (cons (car vlst) (reverse vlst))))
                 )
               )
             ) 1e-6
           )
         )
         z
         (progn
           (prompt "\n\nChecked vectors are colinear - unable to determine clockwise-p of list")
           nil
         )
       )
     )
   )
 )

 (defun MR:GetVertices ( e / l )
   (if e
     (setq l (mapcar 'cdr (vl-remove-if-not '(lambda (x) (eq (car x) 10)) (entget e))))
   )
 )

 (defun MR:GetBulge ( e / l )
   (if e
     (setq l (mapcar 'cdr (vl-remove-if-not '(lambda (x) (eq (car x) 42)) (entget e))))
   )
 )

 (defun _intl (l1 l2 / ll1 ll2 a ls1 ls2)
   (setq ll1 l1
         ll2 l2
   )
   (while
     (setq a (car ll2))
     (while ll1
       (if (equal a (car ll1) 1e-6)
         (setq ls1 (append ls1 (list a))
               ll1 (cdr ll1)
         )
         (setq ll1 (cdr ll1))
       )
     )
     (setq ll2 (cdr ll2)
           ll1 (vl-remove a l1)
     )
   )
   (setq ll1 l1
         ll2 l2
   )
   (while
     (setq a (car ll1))
     (while ll2
       (if (equal a (car ll2) 1e-6)
         (setq ls2 (append ls2 (list a))
               ll2 (cdr ll2)
         )
         (setq ll2 (cdr ll2))
       )
     )
     (setq ll1 (cdr ll1)
           ll2 (vl-remove a l2)
     )
   )
   (if (< (length ls1) (length ls2)) ls1 ls2)
 )

 (defun prelst ( lst el / f )
    (vl-remove-if '(lambda ( a ) (or f (setq f (equal a el 1e-6)))) lst)
 )

 (defun suflst ( lst el )
   (cdr (vl-member-if '(lambda ( a ) (equal a el 1e-6)) lst))
 )
 
 (defun _Buildlist ( sp lst )
   (append (list sp) (suflst lst sp) (prelst lst sp))
 )
 
     (setq sp (getpoint "\nSelect Start Point:"))
     (setq ep (getpoint sp "\nSelect End Point:"))
     (setq ss (ssget (list '(0 . "*POLYLINE") '(-4 . "<or") '(70 . 0) '(70 . 1) '(70 . 128) '(70 . 129) '(-4 . "or>") (cons 410 (if (= 1 (getvar 'cvport)) (getvar 'ctab) "Model")))))
     (progn
       (initget 1 "T B")
       (setq opt (getkword "\nSelect option [Top/Bottom]: "))
     )
     (setq pl (car (nentselp sp)))
     (setq sp (trans sp 1 pl) ep (trans ep 1 pl))
     (while (>= (sslength ss) 1)
       (if (eq (cdr (assoc 0 (entget pl))) "POLYLINE")
         (progn
           (setq hpllst (cons pl hpllst))
           (command "_.convertpoly" "l" pl "")
           (entupd pl)
         )
       )
       (if (eq opt "T")
         (if (not (ListClockwise-p (MR:GetVertices pl)))
           (progn
             (setq rpllst (cons pl rpllst))
             (rlw pl)
           )
         )
         (if (ListClockwise-p (MR:GetVertices pl))
           (progn
             (setq rpllst (cons pl rpllst))
             (rlw pl)
           )
         )
       )
       (setq a (MR:GetVertices pl))
       (setq b (MR:GetBulge pl))
       (if (eq opt "T") 
         (if (ListClockwise-p a)
           (setq ab (mapcar '(lambda (x y) (cons x y)) a b))
           (setq a (reverse a) b (reverse (mapcar '(lambda (x) (* (- 1.0) x)) b)) bb (cdr b) b (append bb (list (car b))) ab (mapcar '(lambda (x y) (cons x y)) a b))
         )
         (if (ListClockwise-p a)
           (setq a (reverse a) b (reverse (mapcar '(lambda (x) (* (- 1.0) x)) b)) bb (cdr b) b (append bb (list (car b))) ab (mapcar '(lambda (x y) (cons x y)) a b)) 
           (setq ab (mapcar '(lambda (x y) (cons x y)) a b))
         )
       )    
       (setq lst (cons a lst) lstab (cons ab lstab))
       (ssdel pl ss)
       (repeat (setq i (sslength ss))
         (setq ent (ssname ss (setq i (1- i))))
         (if (not (vl-catch-all-error-p (vl-catch-all-apply 'vlax-safearray->list (list (vl-catch-all-apply 'vlax-variant-value (list (vla-intersectwith (vlax-ename->vla-object pl) (vlax-ename->vla-object ent) AcExtendNone)))))))
           (setq pll ent)
         )
       )
       (if pll (setq pl pll))
     )
     (setq i -1 loop t)
     (setq lst (reverse lst) lstab (reverse lstab))
     (if (and (cdr (reverse lst)) (cdr (reverse lstab)))
       (setq lst (append lst (cdr (reverse lst))) lstab (append lstab (cdr (reverse lstab))))
     )
     (while loop
       (setq i (1+ i))
       (setq Pls (_Buildlist (setq sp (list (car sp) (cadr sp))) (nth i lst)))
       (foreach pt Pls
         (setq Bls (cons (assocon pt (nth i lstab) 'car 1e-6) Bls))
       )
       (setq Bls (reverse Bls))
       (if (nth (1+ i) lst)
         (if (vl-member-if '(lambda (x) (equal (list (car ep) (cadr ep)) x 1e-6)) (if (/= i (atoi (rtos (/ (length lst) 2.0)))) (prelst Pls (car (_intl Pls (nth (1+ i) lst)))) (if (equal (nth i lst) (last lst)) (last lst) (prelst Pls (last (_intl Pls (nth (1+ i) lst)))))))
           (setq sp (list (car ep) (cadr ep)) loop nil)
           (if (/= i (atoi (rtos (/ (length lst) 2.0)))) (setq sp (car (_intl Pls (nth (1+ i) lst)))) (setq sp (last (_intl Pls (nth (1+ i) lst)))))
         )
         (setq sp (list (car ep) (cadr ep)) loop nil)
       )
       (setq Pls (prelst Pls sp))
       (setq Bls (prelst Bls (assocon sp (nth i lstab) 'car 1e-6)))
       (setq PtlSt (append PtlSt Pls))
       (setq PtBulg (append PtBulg Bls))
       (setq Bls nil)
     )
     (setq PtlSt (append PtlSt (list (list (car ep) (cadr ep)))))
     (setq PtBulg (append PtBulg (list (assocon (list (car ep) (cadr ep)) (reverse (apply 'append (reverse lstab))) 'car 1e-6))))
     (mapcar '(lambda (x) (if (equal (cdr x) nil) (setq PttBulg (cons 0.0 PttBulg)) (setq PttBulg (cons (cdr x) PttBulg)))) PtBulg)
     (setq PttBulg (reverse PttBulg))
     (setq PtlSt (mapcar '(lambda (x) (list (car x) (cadr x))) PtlSt))
     (foreach pl rpllst
       (rlw pl)
     )
     (entmake 
       (append 
         (list 
           (cons 0 "LWPOLYLINE")
           (cons 100 "AcDbEntity")
           (cons 100 "AcDbPolyline")
           (assoc 38 (entget pl))
           (cons 90 (length PtlSt))
           (cons 70 (if (eq 1 (getvar 'plinegen))
                     128
                     0
                   )
           )
         )
         (apply 'append (mapcar (function (lambda ( p b ) (list (cons 10 p) (cons 42 b)))) PtlSt PttBulg))
         (list (assoc 210 (entget pl)))
       )
     )
     (foreach pl hpllst
       (command "_.convertpoly" "h" pl "")
     )
     (sssetfirst nil (ssadd (entlast)))
 (princ)
)

 

Thanks

Edited April 25 by mhy3sx

[marko_ribar]

Try this mod.

 

It should draw both top and bottom... Then you can select what is sufficient and remove what is undesirable...

If you want pick with mouse for side - it has the same effect like selecting opposition - it has equal steps for working drawing situation...

 

(defun c:PlPath-t+b ( / *error* PlPath-foo rlw ListClockwise-p AssocOn MR:GetVertices MR:GetBulges _intl prelst suflst _buildlist tang pprelst ssuflst add_vtx plintav lwsimplify
                        cmd osm sp spf sppar spp ep epf eppar epp uf opt ss n e el p1 p2 nn ss1 ss2 plstart plend pts+buls sss )

  (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com))

  (defun *error* ( m )
    (if uf
      (if command-s
        (command-s "_.ucs" "_p")
        (vl-cmdf "_.ucs" "_p")
      )
    )
    (if (= 8 (logand 8 (getvar (quote undoctl))))
      (if command-s
        (command-s "_.undo" "_e")
        (vl-cmdf "_.undo" "_e")
      )
    )
    (if osm
      (setvar (quote osmode) osm)
    )
    (if cmd
      (setvar (quote cmdecho) cmd)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun lwsimplify ( ent / aa cpt dir doc elst hlst idx keep len newb result
                    v1 v2 v3 vlst x group_on dxf BulgeCenter tang )

    (defun group_on ( inplst gp# / outlst idx subLst )
      (while inplst
        (setq idx -1 subLst nil)
        (while (< (setq idx (1+ idx)) gp#)
          (setq subLst (cons (nth idx inplst) sublst))
        )
        (setq outlst (cons (reverse sublst) outlst))
        (repeat gp# (setq inplst (cdr inplst)))
      )
      (reverse outlst)
    )

    (defun dxf ( key lst ) (cdr (assoc key lst)))

    (defun BulgeCenter ( bulge p1 p2 / delta chord radius center )
       (setq delta (* (atan bulge) 4)
             chord (distance p1 p2)
             radius (/ chord (sin (/ delta 2)) 2)
             center (polar p1 (+ (angle p1 p2) (/ (- pi delta) 2)) radius)
       )
    )

    (defun tang ( a )
      (/ (sin a) (cos a))
    )

    (if (and ent
             (setq elst (entget ent))
             (equal (assoc 0 elst) (cons 0 "LWPOLYLINE"))
        )
      (progn
        (setq idx 0)
        (repeat (fix (vlax-curve-getendparam ent))
          (cond
            ((null keep)
             (setq keep (list 1)
                   dir  (angle (list 0.0 0.0) (vlax-curve-getFirstDeriv ent 0.0))
             ))
            ((or (null(vlax-curve-getFirstDeriv ent idx))
                 (equal dir (setq dir (angle (list 0.0 0.0)
                               (vlax-curve-getFirstDeriv ent idx))) 0.000001))
             (setq keep (cons 0 keep))
            )
            ((setq keep (cons 1 keep)))
          )
          (setq idx (1+ idx))
        )
        (setq vlst (vl-remove-if-not
                    (function (lambda ( x ) (vl-position (car x) (list 40 41 42 10)))) elst))
        (setq vlst (group_on vlst 4))
        (setq idx -1
              len (1- (length vlst))
              keep (reverse (cons 1 keep))
        )
        (while (<= (setq idx (1+ idx)) len)
          (cond
            ;;  catch 2 arcs with same center pt
            ((and (< idx len)
                  (not (zerop (cdr (cadddr (setq v1 (nth idx vlst))))))
                  (setq v3 (nth (+ idx 2) vlst))
                  (not (zerop (cdr (cadddr (setq v2 (nth (1+ idx) vlst))))))
                  (equal (setq cpt (BulgeCenter (dxf 42 v1) (dxf 10 v1) (dxf 10 v2)))
                         (BulgeCenter (dxf 42 v2) (dxf 10 v2) (dxf 10 v3))
                         1e-4)
             )
             ;;  combine the arcs
             (setq aa (+ (* 4 (atan (abs (dxf 42 v1))))
                         (* 4 (atan (abs (dxf 42 v2)))))
                    newb (tang (/ aa 4.0)))
             (if (minusp (dxf 42 v1))
               (setq newb (- (abs newb)))
               (setq newb (abs newb))
             )
             (setq vlst (subst (list (car v1)   ; point
                                     (cadr v1)  ; Start Width
                                     (caddr v2) ; End Width
                                     (cons 42 newb) ; Bulge
                                     )
                               (nth (1+ idx) vlst) vlst))
            )
            ((or (not (zerop (cdr(cadddr (nth idx vlst))))) ; keep arcs
                 (not (zerop (nth idx keep))))
              (setq result (cons (nth idx vlst) result))
            )
          )
        )

        (setq hlst (vl-remove-if
                    (function (lambda ( x ) (vl-position (car x) (list 40 41 42 10)))) elst))
        (mapcar (function (lambda ( x ) (setq hlst (append hlst x)))) (reverse result))
        (setq hlst (subst (cons 90 (length result)) (assoc 90 hlst) hlst))
        (entmod hlst)
      )
    )
  )

  (defun PlPath-foo ( opt pl ssents sp spf sppar ep epf eppar plstart plend / _while a b ab lst lstab ii ent pln ret pls bls ptlst ptbulg pttbulg )

    (defun _while ( i loop lst lstab )
      (while loop
        (setq i (1+ i))
        (setq pls (_buildlist (setq sp (list (car sp) (cadr sp))) (nth i lst)))
        (foreach pt pls
          (setq bls (cons (assocon pt (nth i lstab) (function car) 1e-6) bls))
        )
        (setq bls (reverse bls))
        (if (nth (1+ i) lst)
          (if (vl-member-if (function (lambda ( x ) (equal (list (car ep) (cadr ep)) x 1e-6)))
            (if (/= i (atoi (rtos (/ (length lst) 2.0))))
              (prelst pls (car (_intl pls (nth (1+ i) lst))))
              (if (equal (nth i lst) (last lst) 1e-6)
                (last lst)
                (prelst pls (last (_intl pls (nth (1+ i) lst))))
              )
            ))
            (setq sp (list (car ep) (cadr ep)) loop nil)
            (if (/= i (atoi (rtos (/ (length lst) 2.0))))
              (setq sp (car (_intl pls (nth (1+ i) lst))))
              (setq sp (last (_intl pls (nth (1+ i) lst))))
            )
          )
          (setq sp (list (car ep) (cadr ep)) loop nil)
        )
        (setq pls (prelst pls sp))
        (setq bls (prelst bls (assocon sp (nth i lstab) (function car) 1e-6)))
        (setq ptlst (append ptlst pls))
        (setq ptbulg (append ptbulg bls))
        (setq pls nil bls nil)
      )
      (list ptlst ptbulg)
    )

    (while ssents
      (if (= opt 1)
        (if (and pl (not (ListClockwise-p (MR:GetVertices pl))))
          (progn
            (vl-cmdf "_.pedit" pl "" "_r") ;;; (rlw pl)
            (while (< 0 (getvar (quote cmdactive)))
              (vl-cmdf "")
            )
          )
        )
        (if (and pl (ListClockwise-p (MR:GetVertices pl)))
          (progn
            (vl-cmdf "_.pedit" pl "" "_r") ;;; (rlw pl)
            (while (< 0 (getvar (quote cmdactive)))
              (vl-cmdf "")
            )
          )
        )
      )
      (if (and spf (eq pl plstart))
        (add_vtx plstart sppar)
      )
      (if (and epf (eq pl plend))
        (add_vtx plend eppar)
      )
      (setq a (MR:GetVertices pl))
      (setq b (MR:GetBulges pl))
      (if (= opt 1) 
        (if (not (ListClockwise-p a))
          (setq a (reverse a) b (reverse (mapcar (function (lambda ( x ) (* (- 1.0) x))) b)) b (append (cdr b) (list (car b))) ab (mapcar (function (lambda ( x y ) (cons x y))) a b))
          (setq ab (mapcar (function (lambda ( x y ) (cons x y))) a b))
        )
        (if (ListClockwise-p a)
          (setq a (reverse a) b (reverse (mapcar (function (lambda ( x ) (* (- 1.0) x))) b)) b (append (cdr b) (list (car b))) ab (mapcar (function (lambda ( x y ) (cons x y))) a b)) 
          (setq ab (mapcar (function (lambda ( x y ) (cons x y))) a b))
        )
      )    
      (setq lst (cons a lst) lstab (cons ab lstab))
      (setq ssents (vl-remove pl ssents))
      (repeat (setq ii (length ssents))
        (setq ent (nth (setq ii (1- ii)) ssents))
        (if (not (vl-catch-all-error-p (vl-catch-all-apply (function safearray-value) (list (vl-catch-all-apply (function variant-value) (list (vla-intersectwith (vlax-ename->vla-object pl) (vlax-ename->vla-object ent) acextendnone)))))))
          (setq pln ent)
        )
      )
      (if pln (setq pl pln))
    )
    (setq lst (reverse lst) lstab (reverse lstab))
    (if (and (cdr (reverse lst)) (cdr (reverse lstab)))
      (setq lst (append lst (cdr (reverse lst))) lstab (append lstab (cdr (reverse lstab))))
    )
    (setq ret (_while -1 t lst lstab))
    (setq ptlst (car ret))
    (setq ptbulg (cadr ret))
    (setq ptlst (append ptlst (list (list (car ep) (cadr ep)))))
    (setq ptbulg (append ptbulg (list (assocon (list (car ep) (cadr ep)) (reverse (apply (function append) (reverse lstab))) (function car) 1e-6))))
    (if (vl-some (function (lambda ( x ) (equal (cdr x) nil))) ptbulg)
      (mapcar (function (lambda ( x ) (if (equal (cdr x) nil) (setq pttbulg (cons 0.0 pttbulg)) (setq pttbulg (cons (cdr x) pttbulg))))) ptbulg)
      (setq pttbulg (mapcar (function cdr) (reverse ptbulg)))
    )
    (list
      (setq ptlst (mapcar (function (lambda ( x ) (list (car x) (cadr x)))) ptlst))
      (setq pttbulg (reverse pttbulg))
    )
  )

  (defun rlw ( lw / e x1 x2 x3 x4 x5 x6 )
    ;; by ElpanovEvgeniy
    ;; reverse lwpolyline
    (if (= (cdr (assoc 0 (setq e (entget lw)))) "LWPOLYLINE")
      (progn
        (foreach a1 e
          (cond 
            ( (= (car a1) 10) (setq x2 (cons a1 x2)) )
            ( (= (car a1) 40) (setq x4 (cons (cons 41 (cdr a1)) x4)) )
            ( (= (car a1) 41) (setq x3 (cons (cons 40 (cdr a1)) x3)) )
            ( (= (car a1) 42) (setq x5 (cons (cons 42 (- (cdr a1))) x5)) )
            ( (= (car a1) 210) (setq x6 (cons a1 x6)) )
            ( t (setq x1 (cons a1 x1)) )
          )
        )
        (entmod 
          (append (reverse x1)
            (append
              (apply (function append)
                (apply (function mapcar)
                  (cons (function list)
                    (list
                      x2
                      (cdr (reverse (cons (car x3) (reverse x3))))
                      (cdr (reverse (cons (car x4) (reverse x4))))
                      (cdr (reverse (cons (car x5) (reverse x5))))
                    )
                  )
                )
              )
              x6
            )
          )
        )
        (entupd lw)
      )
    )
  )

  (defun ListClockwise-p ( lst / z vlst )
    (vl-catch-all-apply (function minusp) 
      (list
        (if 
          (not 
            (equal 0.0
              (setq z
                (apply (function +)
                  (mapcar 
                    (function
                      (lambda ( u v )
                        (- (* (car  u) (cadr  v)) (* (car  v) (cadr  u)))
                      )
                    )
                    (setq vlst
                      (mapcar
                        (function
                          (lambda ( a b ) (mapcar (function -) b a))
                        )
                        (mapcar (function (lambda ( x ) (car lst))) lst) 
                        (cdr (reverse (cons (car lst) (reverse lst))))
                      )
                    )
                    (cdr (reverse (cons (car vlst) (reverse vlst))))
                  )
                )
              )
              1e-6
            )
          )
          z
          (progn
            (prompt "\n\nChecked vectors are collinear - unable to determine clockwise-p of list of points (vectors)...")
            (exit)
          )
        )
      )
    )
  )

  (defun assocon ( searchterm lst func fuzz )
    (car
      (vl-member-if
        (function
          (lambda ( pair ) (equal searchterm (apply func (list pair)) fuzz))
        )
        lst
      )
    )
  )

  (defun MR:GetVertices ( ent / p lst )
    (if ent
      ;;; (setq lst (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget ent))))
      (progn
        (setq p -1)
        (while ((if (vlax-curve-isclosed ent) < <=) (setq p (1+ p)) (fix (vlax-curve-getendparam ent)))
          (setq lst (cons (vlax-curve-getpointatparam ent p) lst))
        )
        (mapcar (function (lambda ( x ) (mapcar (function +) (list 0.0 0.0) (trans x 0 ent)))) (reverse lst))
      )
    )
  )

  (defun MR:GetBulges ( ent / p lst )
    (if ent
      ;;; (setq lst (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 42))) (entget ent))))
      (progn
        (setq p -1)
        (while ((if (vlax-curve-isclosed ent) < <=) (setq p (1+ p)) (fix (vlax-curve-getendparam ent)))
          (setq lst (cons (vla-getbulge (vlax-ename->vla-object ent) p) lst))
        )
        (reverse lst)
      )
    )
  )

  (defun _intl ( l1 l2 / ll1 ll2 a ls1 ls2 )
    (setq ll1 l1
          ll2 l2
    )
    (while
      (setq a (car ll2))
      (while ll1
        (if (equal a (car ll1) 1e-8)
          (setq ls1 (append ls1 (list a))
                ll1 (cdr ll1)
          )
          (setq ll1 (cdr ll1))
        )
      )
      (setq ll2 (cdr ll2)
            ll1 (vl-remove a l1)
      )
    )
    (setq ll1 l1
          ll2 l2
    )
    (while
      (setq a (car ll1))
      (while ll2
        (if (equal a (car ll2) 1e-8)
          (setq ls2 (append ls2 (list a))
                ll2 (cdr ll2)
          )
          (setq ll2 (cdr ll2))
        )
      )
      (setq ll1 (cdr ll1)
            ll2 (vl-remove a l2)
      )
    )
    (if (< (length ls1) (length ls2)) ls1 ls2)
  )

  (defun prelst ( lst el / f )
     (vl-remove-if (function (lambda ( a ) (or f (setq f (equal a el 1e-8))))) lst)
  )

  (defun suflst ( lst el )
    (cdr (vl-member-if (function (lambda ( a ) (equal a el 1e-8))) lst))
  )

  (defun _buildlist ( sp lst )
    (append (list sp) (suflst lst sp) (prelst lst sp))
  )

  (defun tang ( a )
    (if (not (equal (cos a) 0.0 1e-8))
      (/ (sin a) (cos a))
      (if (minusp (cos a))
        -1e+308
        1e+308
      )
    )
  )

  (defun pprelst ( lst el index / f n )
    (vl-remove-if
      (function (lambda ( a )
        (setq n (if (not n) 0 (1+ n)))
        (cond
          ( el
            (if (equal a el 1e-6)
              (not (setq f t))
              f
            )
          )
          ( index
            (if (= index n)
              (not (setq f t))
              f
            )
          )
        )
      ))
      lst
    )
  )

  (defun ssuflst ( lst el index / f n )
    (setq f t)
    (vl-remove-if
      (function (lambda ( a )
        (setq n (if (not n) 0 (1+ n)))
        (cond
          ( el
            (if (equal a el 1e-6)
              (setq f nil)
            )
          )
          ( index
            (if (= index n)
              (setq f nil)
            )
          )
        )
        f
      ))
      lst
    )
  )

  (defun add_vtx ( ent_name par / obj bulg sw ew )
    (setq obj (vlax-ename->vla-object ent_name))
    (vla-GetWidth obj (fix par) (quote sw) (quote ew))
    (vla-addVertex
      obj
      (1+ (fix par))
      (vlax-make-variant
        (vlax-safearray-fill
          (vlax-make-safearray vlax-vbdouble (cons 0 1))
          (list
            (car (trans (vlax-curve-getpointatparam obj par) 0 ent_name))
            (cadr (trans (vlax-curve-getpointatparam obj par) 0 ent_name))
          )
        )
      )
    )
    (setq bulg (vla-GetBulge obj (fix par)))
    (vla-SetBulge obj
      (fix par)
      (/
        (sin (/ (* 4 (atan bulg) (- par (fix par))) 4))
        (cos (/ (* 4 (atan bulg) (- par (fix par))) 4))
      )
    )
    (vla-SetBulge obj
      (1+ (fix par))
      (/
        (sin (/ (* 4 (atan bulg) (- (1+ (fix par)) par)) 4))
        (cos (/ (* 4 (atan bulg) (- (1+ (fix par)) par)) 4))
      )
    )
    (vla-SetWidth obj (fix par) sw (+ sw (* (- ew sw) (- par (fix par)))))
    (vla-SetWidth obj (1+ (fix par)) (+ sw (* (- ew sw) (- par (fix par)))) ew)
    (vla-update obj)
  )

  (defun plintav ( ss / intersobj1obj2 LM:Unique AT:GetVertices _reml member-fuzz
                       ssl ent1 ent2 intpts intptsall pl plpts restintpts par )

    (defun intersobj1obj2 ( obj1 obj2 / coords pt ptlst )
      (if (eq (type obj1) (quote ename)) (setq obj1 (vlax-ename->vla-object obj1)))
      (if (eq (type obj2) (quote ename)) (setq obj2 (vlax-ename->vla-object obj2)))
      (setq coords (vl-catch-all-apply (function safearray-value) (list (vl-catch-all-apply (function variant-value) (list (vla-intersectwith obj1 obj2 AcExtendNone))))))
      (if (vl-catch-all-error-p coords)
        (setq ptlst nil)
        (repeat (/ (length coords) 3)
          (setq pt (list (car coords) (cadr coords) (caddr coords)))
          (setq ptlst (cons pt ptlst))
          (setq coords (cdddr coords))
        )
      )
      ptlst
    )

    (defun LM:Unique ( lst )
      (if lst (cons (car lst) (LM:Unique (vl-remove (car lst) (cdr lst)))))
    )

    (defun AT:GetVertices ( e / p l )
      (LM:Unique
        (if e
          (if (eq (setq p (vlax-curve-getendparam e)) (fix p))
            (repeat (setq p (1+ (fix p)))
              (setq l (cons (vlax-curve-getpointatparam e (setq p (1- p))) l))
            )
            (list (vlax-curve-getstartpoint e) (vlax-curve-getendpoint e))
          )
        )
      )
    )

    (defun _reml ( l1 l2 / a n ls )
      (while 
        (setq n nil 
              a (car l2)
        )
        (while (and l1 (null n))
          (if (equal a (car l1) 1e-8)
            (setq l1 (cdr l1) 
                  n t
            )
            (setq ls (append ls (list (car l1)))
                  l1 (cdr l1)
            )
          )
        )
        (setq l2 (cdr l2))
      )
      (append ls l1)
    )

    (defun member-fuzz ( expr lst fuzz )
      (while (and lst (not (equal (car lst) expr fuzz)))
        (setq lst (cdr lst))
      )
      lst
    )

    (foreach ent1 (setq ssl (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex ss))))
      (setq ssl (vl-remove ent1 ssl))
      (foreach ent2 ssl
        (setq intpts (intersobj1obj2 ent1 ent2))
        (setq intptsall (append intpts intptsall))
      )
    )
    (setq i -1)
    (while (setq pl (ssname ss (setq i (1+ i))))
      (setq plpts (AT:GetVertices pl))
      (setq restintpts (_reml intptsall plpts))
      (foreach pt restintpts
        (if 
          (and
            (not (member-fuzz pt plpts 1e-6))
            (setq par (vlax-curve-getparamatpoint pl pt))
          )
          (add_vtx pl par)
        )
      )
    )
  )

  (alert "This routine will find paths overdraw for LWPOLYLINE entities and will replace selected LWPOLYLINE originals with clipboard stored ones during execution...")
  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (setq osm (getvar (quote osmode)))
  (setvar (quote osmode) 545)
  (if (= 0 (getvar (quote worlducs)))
    (progn
      (vl-cmdf "_.ucs" "_w")
      (setq uf t)
    )
  )
  (if (= 8 (logand 8 (getvar (quote undoctl))))
    (if command-s
      (command-s "_.undo" "_e")
      (vl-cmdf "_.undo" "_e")
    )
  )
  (if command-s
    (command-s "_.undo" "_m")
    (vl-cmdf "_.undo" "_m")
  )
  (prompt "\nSelect LWPOLYLINE entities on unlocked layer(s)...")
  (if (setq ss (ssget "_:L" (list (cons 0 "LWPOLYLINE") (cons 410 (if (= 1 (getvar (quote cvport))) (getvar (quote ctab)) "Model")))))
    (progn
      (vl-cmdf "_.copybase" (list 0.0 0.0 0.0) ss "")
      (initget 1)
      (setq sp (getpoint "\nSelect Start Point : "))
      (initget 1)
      (setq ep (getpoint sp "\nSelect End Point : "))
      (if (> (sslength ss) 1)
        (progn
          (plintav ss)
          (setq ss1 (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex ss))))
          (setq ss2 ss1)
          (if (not (setq plstart (car (nentselp sp))))
            (setq plstart (ssname (ssget "_C" (trans sp 1 0) (trans sp 1 0)) 0))
          )
          (entupd plstart)
          (if (not (setq plend (car (nentselp ep))))
            (setq plend (ssname (ssget "_C" (trans ep 1 0) (trans ep 1 0)) 0))
          )
          (entupd plend)
          (setq sp (trans sp 1 plstart))
          (setq ep (trans ep 1 plend))
          (if (not (vl-some (function (lambda ( x ) (equal x (list (car sp) (cadr sp)) 1e-6))) (MR:GetVertices plstart)))
            (setq spf t)
          )
          (if (not (vl-some (function (lambda ( x ) (equal x (list (car ep) (cadr ep)) 1e-6))) (MR:GetVertices plend)))
            (setq epf t)
          )
          (setq spp (list (car sp) (cadr sp) (setq el (vla-get-elevation (vlax-ename->vla-object plstart)))))
          (setq epp (list (car ep) (cadr ep) el))
          (setq sppar (vlax-curve-getparamatpoint plstart (trans spp plstart 0)))
          (setq eppar (vlax-curve-getparamatpoint plend (trans epp plend 0)))
          (repeat (setq n (sslength ss))
            (setq e (ssname ss (setq n (1- n))))
            (setq nn (vla-get-normal (vlax-ename->vla-object e)))
            (if (or (not (zerop el)) (not (equal nn (list 0.0 0.0 1.0) 1e-6)))
              (progn
                (vla-put-elevation (vlax-ename->vla-object e) el)
                (vla-put-normal (vlax-ename->vla-object e) nn)
              )
            )
          )
          (setq opt 0)
          (setq sss (ssadd))
          (repeat 2
            (setq opt (1+ opt))
            (setq sp (list (car spp) (cadr spp)) ep (list (car epp) (cadr epp)))
            (setq pts+buls (PlPath-foo opt plstart (if (= opt 1) ss1 ss2) sp spf sppar ep epf eppar plstart plend))
            (setq e
              (entmakex
                (append
                  (list
                    (cons 0 "LWPOLYLINE")
                    (cons 100 "AcDbEntity")
                    (cons 100 "AcDbPolyline")
                    (cons 38 el)
                    (cons 90 (length (car pts+buls)))
                    (cons 70 (* 128 (getvar (quote plinegen))))
                  )
                  (apply (function append) (mapcar (function (lambda ( p b ) (list (cons 10 p) (cons 42 b)))) (car pts+buls) (cadr pts+buls)))
                  (list (cons 210 (safearray-value (variant-value nn))))
                )
              )
            )
            (lwsimplify e)
            (ssadd e sss)
          )
        )
        (alert "Add linear LWPOLYLINE that is passing through start and end points and restart routine by selecting both LWPOLYLINES and pick start and end points as intersections between both of them...")
      )
      (vl-cmdf "_.erase" ss "")
      (vl-cmdf "_.pasteclip" (list 0.0 0.0 0.0))
      (vl-cmdf "_.draworder" sss "" "_f")
    )
  )
  (*error* nil)
)

 

HTH.

M.R.

Edited Monday at 11:45 PM by marko_ribar

[mhy3sx]

Thanks marko_ribar

[duke]

On 4/25/2024 at 6:13 PM, marko_ribar said:

Try this mod.

 

It should draw both top and bottom... Then you can select what is sufficient and remove what is undesirable...

If you want pick with mouse for side - it has the same effect like selecting opposition - it has equal steps for working drawing situation...

 

(defun c:PlPath-t+b ( / *error* PlPath-foo rlw ListClockwise-p AssocOn MR:GetVertices MR:GetBulges _intl prelst suflst _buildlist tang pprelst ssuflst add_vtx plintav
                        cmd osm sp spf sppar spp ep epf eppar epp uf opt ss n e el nn ss1 ss2 plstart plend pts+buls sss )

  (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com))

  (defun *error* ( m )
    (if uf
      (if command-s
        (command-s "_ucs" "_p")
        (vl-cmdf "_ucs" "_p")
      )
    )
    (if osm
      (setvar (quote osmode) osm)
    )
    (if cmd
      (setvar (quote cmdecho) cmd)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun PlPath-foo ( opt pl ss spf sppar epf eppar plstart plend / _while a b bb ab lst lstab ii ent pln ret pls bls ptlst ptbulg pttbulg )

    (defun _while ( i loop )
      (while loop
        (setq i (1+ i))
        (setq pls (_buildlist (setq sp (list (car sp) (cadr sp))) (nth i lst)))
        (foreach pt pls
          (setq bls (cons (assocon pt (nth i lstab) (function car) 1e-6) bls))
        )
        (setq bls (reverse bls))
        (if (nth (1+ i) lst)
          (if (vl-member-if (function (lambda ( x ) (equal (list (car ep) (cadr ep)) x 1e-6)))
            (if (/= i (atoi (rtos (/ (length lst) 2.0))))
              (prelst pls (car (_intl pls (nth (1+ i) lst))))
              (if (equal (nth i lst) (last lst))
                (last lst)
                (prelst pls (last (_intl pls (nth (1+ i) lst))))
              )
            ))
            (setq sp (list (car ep) (cadr ep)) loop nil)
            (if (/= i (atoi (rtos (/ (length lst) 2.0))))
              (setq sp (car (_intl pls (nth (1+ i) lst))))
              (setq sp (last (_intl pls (nth (1+ i) lst))))
            )
          )
          (setq sp (list (car ep) (cadr ep)) loop nil)
        )
        (setq pls (prelst pls sp))
        (setq bls (prelst bls (assocon sp (nth i lstab) (function car) 1e-6)))
        (setq ptlst (append ptlst pls))
        (setq ptbulg (append ptbulg bls))
        (setq pls nil bls nil)
      )
      (list ptlst ptbulg)
    )

    (while ss
      (gc)
      (if (= opt 1)
        (if (not (ListClockwise-p (MR:GetVertices pl)))
          (rlw pl)
        )
        (if (ListClockwise-p (MR:GetVertices pl))
          (rlw pl)
        )
      )
      (if (and spf (eq pl plstart))
        (add_vtx plstart sppar)
      )
      (if (and epf (eq pl plend))
        (add_vtx plend eppar)
      )
      (setq a (MR:GetVertices pl))
      (setq b (MR:GetBulges pl))
      (if (= opt 1) 
        (if (not (ListClockwise-p a))
          (setq a (reverse a) b (reverse (mapcar (function (lambda ( x ) (* (- 1.0) x))) b)) bb (cdr b) b (append bb (list (car b))) ab (mapcar (function (lambda ( x y ) (cons x y))) a b))
          (setq ab (mapcar (function (lambda ( x y ) (cons x y))) a b))
        )
        (if (ListClockwise-p a)
          (setq a (reverse a) b (reverse (mapcar (function (lambda ( x ) (* (- 1.0) x))) b)) bb (cdr b) b (append bb (list (car b))) ab (mapcar (function (lambda ( x y ) (cons x y))) a b)) 
          (setq ab (mapcar (function (lambda ( x y ) (cons x y))) a b))
        )
      )    
      (setq lst (cons a lst) lstab (cons ab lstab))
      (setq ss (vl-remove pl ss))
      (repeat (setq ii (length ss))
        (setq ent (nth (setq ii (1- ii)) ss))
        (if (not (vl-catch-all-error-p (vl-catch-all-apply (function safearray-value) (list (vl-catch-all-apply (function variant-value) (list (vla-intersectwith (vlax-ename->vla-object pl) (vlax-ename->vla-object ent) AcExtendNone)))))))
          (setq pln ent)
        )
      )
      (if pln (setq pl pln))
    )
    (setq lst (reverse lst) lstab (reverse lstab))
    (if (and (cdr (reverse lst)) (cdr (reverse lstab)))
      (setq lst (append lst (cdr (reverse lst))) lstab (append lstab (cdr (reverse lstab))))
    )
    (setq ret (_while -1 t))
    (setq ptlst (car ret))
    (setq ptbulg (cadr ret))
    (setq ptlst (append ptlst (list (list (car ep) (cadr ep)))))
    (setq ptbulg (append ptbulg (list (assocon (list (car ep) (cadr ep)) (reverse (apply (function append) (reverse lstab))) (function car) 1e-6))))
    (if (vl-some (function (lambda ( x ) (null x))) ptlst)
      (setq ptlst (vl-remove nil ptlst))
    )
    (if (vl-some (function (lambda ( x ) (null x))) ptbulg)
      (setq ptbulg (vl-remove nil ptbulg))
    )
    (if (vl-some (function (lambda ( x ) (equal (cdr x) nil))) ptbulg)
      (mapcar (function (lambda ( x ) (if (equal (cdr x) nil) (setq pttbulg (cons 0.0 pttbulg)) (setq pttbulg (cons (cdr x) pttbulg))))) ptbulg)
      (setq pttbulg (mapcar (function cdr) (reverse ptbulg)))
    )
    (list
      (setq ptlst (mapcar (function (lambda ( x ) (list (car x) (cadr x)))) ptlst))
      (setq pttbulg (reverse pttbulg))
    )
  )

  (defun rlw ( lw / e x1 x2 x3 x4 x5 x6 )
    ;; by ElpanovEvgeniy
    ;; reverse lwpolyline
    (if (= (cdr (assoc 0 (setq e (entget lw)))) "LWPOLYLINE")
      (progn
        (foreach a1 e
          (cond 
            ( (= (car a1) 10) (setq x2 (cons a1 x2)) )
            ( (= (car a1) 40) (setq x4 (cons (cons 41 (cdr a1)) x4)) )
            ( (= (car a1) 41) (setq x3 (cons (cons 40 (cdr a1)) x3)) )
            ( (= (car a1) 42) (setq x5 (cons (cons 42 (- (cdr a1))) x5)) )
            ( (= (car a1) 210) (setq x6 (cons a1 x6)) )
            ( t (setq x1 (cons a1 x1)) )
          )
        )
        (entmod 
          (append (reverse x1)
            (append
              (apply (function append)
                (apply (function mapcar)
                  (cons (function list)
                    (list
                      x2
                      (cdr (reverse (cons (car x3) (reverse x3))))
                      (cdr (reverse (cons (car x4) (reverse x4))))
                      (cdr (reverse (cons (car x5) (reverse x5))))
                    )
                  )
                )
              )
              x6
            )
          )
        )
        (entupd lw)
      )
    )
  )

  (defun ListClockwise-p ( lst / z vlst )
    (vl-catch-all-apply (function minusp) 
      (list
        (if 
          (not 
            (equal 0.0
              (setq z
                (apply (function +)
                  (mapcar 
                    (function
                      (lambda ( u v )
                        (- (* (car  u) (cadr  v)) (* (car  v) (cadr  u)))
                      )
                    )
                    (setq vlst
                      (mapcar
                        (function
                          (lambda ( a b ) (mapcar (function -) b a))
                        )
                        (mapcar (function (lambda ( x ) (car lst))) lst) 
                        (cdr (reverse (cons (car lst) (reverse lst))))
                      )
                    )
                    (cdr (reverse (cons (car vlst) (reverse vlst))))
                  )
                )
              )
              1e-6
            )
          )
          z
          (progn
            (prompt "\n\nChecked vectors are collinear - unable to determine clockwise-p of list")
            (exit)
          )
        )
      )
    )
  )

  (defun assocon ( searchterm lst func fuzz )
    (car
      (vl-member-if
        (function
          (lambda ( pair ) (equal searchterm (apply func (list pair)) fuzz))
        )
        lst
      )
    )
  )

  (defun MR:GetVertices ( ent / lst )
    (if ent
      (setq lst (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget ent))))
    )
  )

  (defun MR:GetBulges ( ent / lst )
    (if ent
      (setq lst (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 42))) (entget ent))))
    )
  )

  (defun _intl ( l1 l2 / ll1 ll2 a ls1 ls2 )
    (setq ll1 l1
          ll2 l2
    )
    (while
      (setq a (car ll2))
      (while ll1
        (if (equal a (car ll1) 1e-8)
          (setq ls1 (append ls1 (list a))
                ll1 (cdr ll1)
          )
          (setq ll1 (cdr ll1))
        )
      )
      (setq ll2 (cdr ll2)
            ll1 (vl-remove a l1)
      )
    )
    (setq ll1 l1
          ll2 l2
    )
    (while
      (setq a (car ll1))
      (while ll2
        (if (equal a (car ll2) 1e-8)
          (setq ls2 (append ls2 (list a))
                ll2 (cdr ll2)
          )
          (setq ll2 (cdr ll2))
        )
      )
      (setq ll1 (cdr ll1)
            ll2 (vl-remove a l2)
      )
    )
    (if (< (length ls1) (length ls2)) ls1 ls2)
  )

  (defun prelst ( lst el / f )
     (vl-remove-if (function (lambda ( a ) (or f (setq f (equal a el 1e-8))))) lst)
  )

  (defun suflst ( lst el )
    (cdr (vl-member-if (function (lambda ( a ) (equal a el 1e-8))) lst))
  )

  (defun _buildlist ( sp lst )
    (append (list sp) (suflst lst sp) (prelst lst sp))
  )

  (defun tang ( a )
    (if (not (equal (cos a) 0.0 1e-8))
      (/ (sin a) (cos a))
      (if (minusp (cos a))
        -1e+308
        1e+308
      )
    )
  )

  (defun pprelst ( lst el index / f n )
    (vl-remove-if
      (function (lambda ( a )
        (setq n (if (not n) 0 (1+ n)))
        (cond
          ( el
            (if (equal a el 1e-6)
              (not (setq f t))
              f
            )
          )
          ( index
            (if (= index n)
              (not (setq f t))
              f
            )
          )
        )
      ))
      lst
    )
  )

  (defun ssuflst ( lst el index / f n )
    (setq f t)
    (vl-remove-if
      (function (lambda ( a )
        (setq n (if (not n) 0 (1+ n)))
        (cond
          ( el
            (if (equal a el 1e-6)
              (setq f nil)
            )
          )
          ( index
            (if (= index n)
              (setq f nil)
            )
          )
        )
        f
      ))
      lst
    )
  )

  (defun add_vtx ( ent_name par / obj bulg sw ew )
    (setq obj (vlax-ename->vla-object ent_name))
    (vla-GetWidth obj (fix par) (quote sw) (quote ew))
    (vla-addVertex
      obj
      (1+ (fix par))
      (vlax-make-variant
        (vlax-safearray-fill
          (vlax-make-safearray vlax-vbdouble (cons 0 1))
          (list
            (car (trans (vlax-curve-getpointatparam obj par) 0 ent_name))
            (cadr (trans (vlax-curve-getpointatparam obj par) 0 ent_name))
          )
        )
      )
    )
    (setq bulg (vla-GetBulge obj (fix par)))
    (vla-SetBulge obj
      (fix par)
      (/
        (sin (/ (* 4 (atan bulg) (- par (fix par))) 4))
        (cos (/ (* 4 (atan bulg) (- par (fix par))) 4))
      )
    )
    (vla-SetBulge obj
      (1+ (fix par))
      (/
        (sin (/ (* 4 (atan bulg) (- (1+ (fix par)) par)) 4))
        (cos (/ (* 4 (atan bulg) (- (1+ (fix par)) par)) 4))
      )
    )
    (vla-SetWidth obj (fix par) sw (+ sw (* (- ew sw) (- par (fix par)))))
    (vla-SetWidth obj (1+ (fix par)) (+ sw (* (- ew sw) (- par (fix par)))) ew)
    (vla-update obj)
  )

  (defun plintav ( ss / intersobj1obj2 LM:Unique AT:GetVertices _reml member-fuzz
                       ssl ent1 ent2 intpts intptsall pl plpts restintpts par )

    (defun intersobj1obj2 ( obj1 obj2 / coords pt ptlst )
      (if (eq (type obj1) (quote ename)) (setq obj1 (vlax-ename->vla-object obj1)))
      (if (eq (type obj2) (quote ename)) (setq obj2 (vlax-ename->vla-object obj2)))
      (setq coords (vl-catch-all-apply (function safearray-value) (list (vl-catch-all-apply (function variant-value) (list (vla-intersectwith obj1 obj2 AcExtendNone))))))
      (if (vl-catch-all-error-p coords)
        (setq ptlst nil)
        (repeat (/ (length coords) 3)
          (setq pt (list (car coords) (cadr coords) (caddr coords)))
          (setq ptlst (cons pt ptlst))
          (setq coords (cdddr coords))
        )
      )
      ptlst
    )  

    (defun LM:Unique ( lst )
      (if lst (cons (car lst) (LM:Unique (vl-remove (car lst) (cdr lst)))))
    )

    (defun AT:GetVertices ( e / p l )
      (LM:Unique
        (if e
          (if (eq (setq p (vlax-curve-getendparam e)) (fix p))
            (repeat (setq p (1+ (fix p)))
              (setq l (cons (vlax-curve-getpointatparam e (setq p (1- p))) l))
            )
            (list (vlax-curve-getstartpoint e) (vlax-curve-getendpoint e))
          )
        )
      )
    )

    (defun _reml ( l1 l2 / a n ls )
      (while 
        (setq n nil 
              a (car l2)
        )
        (while (and l1 (null n))
          (if (equal a (car l1) 1e-8)
            (setq l1 (cdr l1) 
                  n t
            )
            (setq ls (append ls (list (car l1)))
                  l1 (cdr l1)
            )
          )
        )
        (setq l2 (cdr l2))
      )
      (append ls l1)
    )

    (defun member-fuzz ( expr lst fuzz )
      (while (and lst (not (equal (car lst) expr fuzz)))
        (setq lst (cdr lst))
      )
      lst
    )

    (foreach ent1 (setq ssl (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex ss))))
      (setq ssl (vl-remove ent1 ssl))
      (foreach ent2 ssl
        (setq intpts (intersobj1obj2 ent1 ent2))
        (setq intptsall (append intpts intptsall))
      )
    )
    (setq i -1)
    (while (setq pl (ssname ss (setq i (1+ i))))
      (setq plpts (AT:GetVertices pl))
      (setq restintpts (_reml intptsall plpts))
      (foreach pt restintpts
        (if 
          (and
            (not (member-fuzz pt plpts 1e-6))
            (setq par (vlax-curve-getparamatpoint pl pt))
          )
          (add_vtx pl par)        
        )
      )
    )
  )

  (alert "This routine will find paths overdraw for LWPOLYLINE entities and will replace selected LWPOLYLINE originals with clipboard stored ones during execution...")
  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (setq osm (getvar (quote osmode)))
  (setvar (quote osmode) 513)
  (if (= 0 (getvar (quote worlducs)))
    (progn
      (vl-cmdf "_.ucs" "_w")
      (setq uf t)
    )
  )
  (prompt "\nSelect LWPOLYLINE entities on unlocked layer(s)...")
  (if (setq ss (ssget "_:L" (list (cons 0 "LWPOLYLINE") (cons 410 (if (= 1 (getvar (quote cvport))) (getvar (quote ctab)) "Model")))))
    (progn
      (vl-cmdf "_.copybase" (list 0.0 0.0 0.0) ss "")
      (initget 1)
      (setq sp (getpoint "\nSelect Start Point : "))
      (initget 1)
      (setq ep (getpoint sp "\nSelect End Point : "))
      (plintav ss)
      (setq ss1 (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex ss))))
      (setq ss2 ss1)
      (if (not (setq plstart (car (nentselp sp))))
        (setq plstart (ssname (ssget "_C" (trans sp 1 0) (trans sp 1 0)) 0))
      )
      (entupd plstart)
      (if (not (setq plend (car (nentselp ep))))
        (setq plend (ssname (ssget "_C" (trans ep 1 0) (trans ep 1 0)) 0))
      )
      (entupd plend)
      (setq sp (trans sp 1 plstart))
      (setq ep (trans ep 1 plend))
      (if (not (vl-some (function (lambda ( x ) (equal x (list (car sp) (cadr sp)) 1e-6))) (MR:GetVertices plstart)))
        (setq spf t)
      )
      (if (not (vl-some (function (lambda ( x ) (equal x (list (car ep) (cadr ep)) 1e-6))) (MR:GetVertices plend)))
        (setq epf t)
      )
      (setq spp (list (car sp) (cadr sp) (setq el (vla-get-elevation (vlax-ename->vla-object plstart)))))
      (setq epp (list (car ep) (cadr ep) el))
      (setq sppar (vlax-curve-getparamatpoint plstart (trans spp plstart 0)))
      (setq eppar (vlax-curve-getparamatpoint plend (trans epp plend 0)))
      (repeat (setq n (sslength ss))
        (setq e (ssname ss (setq n (1- n))))
        (entupd e)
        (setq nn (vla-get-normal (vlax-ename->vla-object e)))
        (if (or (not (zerop el)) (not (equal nn (list 0.0 0.0 1.0) 1e-6)))
          (progn
            (vla-put-elevation (vlax-ename->vla-object e) el)
            (vla-put-normal (vlax-ename->vla-object e) nn)
          )
        )
      )
      (setq opt 0)
      (setq sss (ssadd))
      (repeat 2
        (setq opt (1+ opt))
        (setq sp spp ep epp)
        (setq pts+buls (PlPath-foo opt plstart (if (= opt 1) ss1 ss2) spf sppar epf eppar plstart plend))
        (setq e
          (entmakex
            (append
              (list
                (cons 0 "LWPOLYLINE")
                (cons 100 "AcDbEntity")
                (cons 100 "AcDbPolyline")
                (cons 38 el)
                (cons 90 (length (car pts+buls)))
                (cons 70 (* 128 (getvar (quote plinegen))))
              )
              (apply (function append) (mapcar (function (lambda ( p b ) (list (cons 10 p) (cons 42 b)))) (car pts+buls) (cadr pts+buls)))
              (list (cons 210 (safearray-value (variant-value nn))))
            )
          )
        )
        (ssadd e sss)
      )
      (vl-cmdf "_.erase" ss "")
      (vl-cmdf "_.pasteclip" (list 0.0 0.0 0.0))
      (vl-cmdf "_.draworder" sss "" "_f")
    )
  )
  (*error* nil)
)

 

HTH.

M.R.

Hi MARKO, your routine works perfectly !!!
really thanks for your hard work !!!
its perfect !!!

[duke]

On 4/25/2024 at 6:13 PM, marko_ribar said:

Try this mod.

 

It should draw both top and bottom... Then you can select what is sufficient and remove what is undesirable...

If you want pick with mouse for side - it has the same effect like selecting opposition - it has equal steps for working drawing situation...

 

(defun c:PlPath-t+b ( / *error* PlPath-foo rlw ListClockwise-p AssocOn MR:GetVertices MR:GetBulges _intl prelst suflst _buildlist tang pprelst ssuflst add_vtx plintav
                        cmd osm sp spf sppar spp ep epf eppar epp uf opt ss n e el nn ss1 ss2 plstart plend pts+buls sss )

  (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com))

  (defun *error* ( m )
    (if uf
      (if command-s
        (command-s "_ucs" "_p")
        (vl-cmdf "_ucs" "_p")
      )
    )
    (if osm
      (setvar (quote osmode) osm)
    )
    (if cmd
      (setvar (quote cmdecho) cmd)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun PlPath-foo ( opt pl ss spf sppar epf eppar plstart plend / _while a b bb ab lst lstab ii ent pln ret pls bls ptlst ptbulg pttbulg )

    (defun _while ( i loop )
      (while loop
        (setq i (1+ i))
        (setq pls (_buildlist (setq sp (list (car sp) (cadr sp))) (nth i lst)))
        (foreach pt pls
          (setq bls (cons (assocon pt (nth i lstab) (function car) 1e-6) bls))
        )
        (setq bls (reverse bls))
        (if (nth (1+ i) lst)
          (if (vl-member-if (function (lambda ( x ) (equal (list (car ep) (cadr ep)) x 1e-6)))
            (if (/= i (atoi (rtos (/ (length lst) 2.0))))
              (prelst pls (car (_intl pls (nth (1+ i) lst))))
              (if (equal (nth i lst) (last lst))
                (last lst)
                (prelst pls (last (_intl pls (nth (1+ i) lst))))
              )
            ))
            (setq sp (list (car ep) (cadr ep)) loop nil)
            (if (/= i (atoi (rtos (/ (length lst) 2.0))))
              (setq sp (car (_intl pls (nth (1+ i) lst))))
              (setq sp (last (_intl pls (nth (1+ i) lst))))
            )
          )
          (setq sp (list (car ep) (cadr ep)) loop nil)
        )
        (setq pls (prelst pls sp))
        (setq bls (prelst bls (assocon sp (nth i lstab) (function car) 1e-6)))
        (setq ptlst (append ptlst pls))
        (setq ptbulg (append ptbulg bls))
        (setq pls nil bls nil)
      )
      (list ptlst ptbulg)
    )

    (while ss
      (gc)
      (if (= opt 1)
        (if (not (ListClockwise-p (MR:GetVertices pl)))
          (rlw pl)
        )
        (if (ListClockwise-p (MR:GetVertices pl))
          (rlw pl)
        )
      )
      (if (and spf (eq pl plstart))
        (add_vtx plstart sppar)
      )
      (if (and epf (eq pl plend))
        (add_vtx plend eppar)
      )
      (setq a (MR:GetVertices pl))
      (setq b (MR:GetBulges pl))
      (if (= opt 1) 
        (if (not (ListClockwise-p a))
          (setq a (reverse a) b (reverse (mapcar (function (lambda ( x ) (* (- 1.0) x))) b)) bb (cdr b) b (append bb (list (car b))) ab (mapcar (function (lambda ( x y ) (cons x y))) a b))
          (setq ab (mapcar (function (lambda ( x y ) (cons x y))) a b))
        )
        (if (ListClockwise-p a)
          (setq a (reverse a) b (reverse (mapcar (function (lambda ( x ) (* (- 1.0) x))) b)) bb (cdr b) b (append bb (list (car b))) ab (mapcar (function (lambda ( x y ) (cons x y))) a b)) 
          (setq ab (mapcar (function (lambda ( x y ) (cons x y))) a b))
        )
      )    
      (setq lst (cons a lst) lstab (cons ab lstab))
      (setq ss (vl-remove pl ss))
      (repeat (setq ii (length ss))
        (setq ent (nth (setq ii (1- ii)) ss))
        (if (not (vl-catch-all-error-p (vl-catch-all-apply (function safearray-value) (list (vl-catch-all-apply (function variant-value) (list (vla-intersectwith (vlax-ename->vla-object pl) (vlax-ename->vla-object ent) AcExtendNone)))))))
          (setq pln ent)
        )
      )
      (if pln (setq pl pln))
    )
    (setq lst (reverse lst) lstab (reverse lstab))
    (if (and (cdr (reverse lst)) (cdr (reverse lstab)))
      (setq lst (append lst (cdr (reverse lst))) lstab (append lstab (cdr (reverse lstab))))
    )
    (setq ret (_while -1 t))
    (setq ptlst (car ret))
    (setq ptbulg (cadr ret))
    (setq ptlst (append ptlst (list (list (car ep) (cadr ep)))))
    (setq ptbulg (append ptbulg (list (assocon (list (car ep) (cadr ep)) (reverse (apply (function append) (reverse lstab))) (function car) 1e-6))))
    (if (vl-some (function (lambda ( x ) (null x))) ptlst)
      (setq ptlst (vl-remove nil ptlst))
    )
    (if (vl-some (function (lambda ( x ) (null x))) ptbulg)
      (setq ptbulg (vl-remove nil ptbulg))
    )
    (if (vl-some (function (lambda ( x ) (equal (cdr x) nil))) ptbulg)
      (mapcar (function (lambda ( x ) (if (equal (cdr x) nil) (setq pttbulg (cons 0.0 pttbulg)) (setq pttbulg (cons (cdr x) pttbulg))))) ptbulg)
      (setq pttbulg (mapcar (function cdr) (reverse ptbulg)))
    )
    (list
      (setq ptlst (mapcar (function (lambda ( x ) (list (car x) (cadr x)))) ptlst))
      (setq pttbulg (reverse pttbulg))
    )
  )

  (defun rlw ( lw / e x1 x2 x3 x4 x5 x6 )
    ;; by ElpanovEvgeniy
    ;; reverse lwpolyline
    (if (= (cdr (assoc 0 (setq e (entget lw)))) "LWPOLYLINE")
      (progn
        (foreach a1 e
          (cond 
            ( (= (car a1) 10) (setq x2 (cons a1 x2)) )
            ( (= (car a1) 40) (setq x4 (cons (cons 41 (cdr a1)) x4)) )
            ( (= (car a1) 41) (setq x3 (cons (cons 40 (cdr a1)) x3)) )
            ( (= (car a1) 42) (setq x5 (cons (cons 42 (- (cdr a1))) x5)) )
            ( (= (car a1) 210) (setq x6 (cons a1 x6)) )
            ( t (setq x1 (cons a1 x1)) )
          )
        )
        (entmod 
          (append (reverse x1)
            (append
              (apply (function append)
                (apply (function mapcar)
                  (cons (function list)
                    (list
                      x2
                      (cdr (reverse (cons (car x3) (reverse x3))))
                      (cdr (reverse (cons (car x4) (reverse x4))))
                      (cdr (reverse (cons (car x5) (reverse x5))))
                    )
                  )
                )
              )
              x6
            )
          )
        )
        (entupd lw)
      )
    )
  )

  (defun ListClockwise-p ( lst / z vlst )
    (vl-catch-all-apply (function minusp) 
      (list
        (if 
          (not 
            (equal 0.0
              (setq z
                (apply (function +)
                  (mapcar 
                    (function
                      (lambda ( u v )
                        (- (* (car  u) (cadr  v)) (* (car  v) (cadr  u)))
                      )
                    )
                    (setq vlst
                      (mapcar
                        (function
                          (lambda ( a b ) (mapcar (function -) b a))
                        )
                        (mapcar (function (lambda ( x ) (car lst))) lst) 
                        (cdr (reverse (cons (car lst) (reverse lst))))
                      )
                    )
                    (cdr (reverse (cons (car vlst) (reverse vlst))))
                  )
                )
              )
              1e-6
            )
          )
          z
          (progn
            (prompt "\n\nChecked vectors are collinear - unable to determine clockwise-p of list")
            (exit)
          )
        )
      )
    )
  )

  (defun assocon ( searchterm lst func fuzz )
    (car
      (vl-member-if
        (function
          (lambda ( pair ) (equal searchterm (apply func (list pair)) fuzz))
        )
        lst
      )
    )
  )

  (defun MR:GetVertices ( ent / lst )
    (if ent
      (setq lst (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget ent))))
    )
  )

  (defun MR:GetBulges ( ent / lst )
    (if ent
      (setq lst (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 42))) (entget ent))))
    )
  )

  (defun _intl ( l1 l2 / ll1 ll2 a ls1 ls2 )
    (setq ll1 l1
          ll2 l2
    )
    (while
      (setq a (car ll2))
      (while ll1
        (if (equal a (car ll1) 1e-8)
          (setq ls1 (append ls1 (list a))
                ll1 (cdr ll1)
          )
          (setq ll1 (cdr ll1))
        )
      )
      (setq ll2 (cdr ll2)
            ll1 (vl-remove a l1)
      )
    )
    (setq ll1 l1
          ll2 l2
    )
    (while
      (setq a (car ll1))
      (while ll2
        (if (equal a (car ll2) 1e-8)
          (setq ls2 (append ls2 (list a))
                ll2 (cdr ll2)
          )
          (setq ll2 (cdr ll2))
        )
      )
      (setq ll1 (cdr ll1)
            ll2 (vl-remove a l2)
      )
    )
    (if (< (length ls1) (length ls2)) ls1 ls2)
  )

  (defun prelst ( lst el / f )
     (vl-remove-if (function (lambda ( a ) (or f (setq f (equal a el 1e-8))))) lst)
  )

  (defun suflst ( lst el )
    (cdr (vl-member-if (function (lambda ( a ) (equal a el 1e-8))) lst))
  )

  (defun _buildlist ( sp lst )
    (append (list sp) (suflst lst sp) (prelst lst sp))
  )

  (defun tang ( a )
    (if (not (equal (cos a) 0.0 1e-8))
      (/ (sin a) (cos a))
      (if (minusp (cos a))
        -1e+308
        1e+308
      )
    )
  )

  (defun pprelst ( lst el index / f n )
    (vl-remove-if
      (function (lambda ( a )
        (setq n (if (not n) 0 (1+ n)))
        (cond
          ( el
            (if (equal a el 1e-6)
              (not (setq f t))
              f
            )
          )
          ( index
            (if (= index n)
              (not (setq f t))
              f
            )
          )
        )
      ))
      lst
    )
  )

  (defun ssuflst ( lst el index / f n )
    (setq f t)
    (vl-remove-if
      (function (lambda ( a )
        (setq n (if (not n) 0 (1+ n)))
        (cond
          ( el
            (if (equal a el 1e-6)
              (setq f nil)
            )
          )
          ( index
            (if (= index n)
              (setq f nil)
            )
          )
        )
        f
      ))
      lst
    )
  )

  (defun add_vtx ( ent_name par / obj bulg sw ew )
    (setq obj (vlax-ename->vla-object ent_name))
    (vla-GetWidth obj (fix par) (quote sw) (quote ew))
    (vla-addVertex
      obj
      (1+ (fix par))
      (vlax-make-variant
        (vlax-safearray-fill
          (vlax-make-safearray vlax-vbdouble (cons 0 1))
          (list
            (car (trans (vlax-curve-getpointatparam obj par) 0 ent_name))
            (cadr (trans (vlax-curve-getpointatparam obj par) 0 ent_name))
          )
        )
      )
    )
    (setq bulg (vla-GetBulge obj (fix par)))
    (vla-SetBulge obj
      (fix par)
      (/
        (sin (/ (* 4 (atan bulg) (- par (fix par))) 4))
        (cos (/ (* 4 (atan bulg) (- par (fix par))) 4))
      )
    )
    (vla-SetBulge obj
      (1+ (fix par))
      (/
        (sin (/ (* 4 (atan bulg) (- (1+ (fix par)) par)) 4))
        (cos (/ (* 4 (atan bulg) (- (1+ (fix par)) par)) 4))
      )
    )
    (vla-SetWidth obj (fix par) sw (+ sw (* (- ew sw) (- par (fix par)))))
    (vla-SetWidth obj (1+ (fix par)) (+ sw (* (- ew sw) (- par (fix par)))) ew)
    (vla-update obj)
  )

  (defun plintav ( ss / intersobj1obj2 LM:Unique AT:GetVertices _reml member-fuzz
                       ssl ent1 ent2 intpts intptsall pl plpts restintpts par )

    (defun intersobj1obj2 ( obj1 obj2 / coords pt ptlst )
      (if (eq (type obj1) (quote ename)) (setq obj1 (vlax-ename->vla-object obj1)))
      (if (eq (type obj2) (quote ename)) (setq obj2 (vlax-ename->vla-object obj2)))
      (setq coords (vl-catch-all-apply (function safearray-value) (list (vl-catch-all-apply (function variant-value) (list (vla-intersectwith obj1 obj2 AcExtendNone))))))
      (if (vl-catch-all-error-p coords)
        (setq ptlst nil)
        (repeat (/ (length coords) 3)
          (setq pt (list (car coords) (cadr coords) (caddr coords)))
          (setq ptlst (cons pt ptlst))
          (setq coords (cdddr coords))
        )
      )
      ptlst
    )  

    (defun LM:Unique ( lst )
      (if lst (cons (car lst) (LM:Unique (vl-remove (car lst) (cdr lst)))))
    )

    (defun AT:GetVertices ( e / p l )
      (LM:Unique
        (if e
          (if (eq (setq p (vlax-curve-getendparam e)) (fix p))
            (repeat (setq p (1+ (fix p)))
              (setq l (cons (vlax-curve-getpointatparam e (setq p (1- p))) l))
            )
            (list (vlax-curve-getstartpoint e) (vlax-curve-getendpoint e))
          )
        )
      )
    )

    (defun _reml ( l1 l2 / a n ls )
      (while 
        (setq n nil 
              a (car l2)
        )
        (while (and l1 (null n))
          (if (equal a (car l1) 1e-8)
            (setq l1 (cdr l1) 
                  n t
            )
            (setq ls (append ls (list (car l1)))
                  l1 (cdr l1)
            )
          )
        )
        (setq l2 (cdr l2))
      )
      (append ls l1)
    )

    (defun member-fuzz ( expr lst fuzz )
      (while (and lst (not (equal (car lst) expr fuzz)))
        (setq lst (cdr lst))
      )
      lst
    )

    (foreach ent1 (setq ssl (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex ss))))
      (setq ssl (vl-remove ent1 ssl))
      (foreach ent2 ssl
        (setq intpts (intersobj1obj2 ent1 ent2))
        (setq intptsall (append intpts intptsall))
      )
    )
    (setq i -1)
    (while (setq pl (ssname ss (setq i (1+ i))))
      (setq plpts (AT:GetVertices pl))
      (setq restintpts (_reml intptsall plpts))
      (foreach pt restintpts
        (if 
          (and
            (not (member-fuzz pt plpts 1e-6))
            (setq par (vlax-curve-getparamatpoint pl pt))
          )
          (add_vtx pl par)        
        )
      )
    )
  )

  (alert "This routine will find paths overdraw for LWPOLYLINE entities and will replace selected LWPOLYLINE originals with clipboard stored ones during execution...")
  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (setq osm (getvar (quote osmode)))
  (setvar (quote osmode) 513)
  (if (= 0 (getvar (quote worlducs)))
    (progn
      (vl-cmdf "_.ucs" "_w")
      (setq uf t)
    )
  )
  (prompt "\nSelect LWPOLYLINE entities on unlocked layer(s)...")
  (if (setq ss (ssget "_:L" (list (cons 0 "LWPOLYLINE") (cons 410 (if (= 1 (getvar (quote cvport))) (getvar (quote ctab)) "Model")))))
    (progn
      (vl-cmdf "_.copybase" (list 0.0 0.0 0.0) ss "")
      (initget 1)
      (setq sp (getpoint "\nSelect Start Point : "))
      (initget 1)
      (setq ep (getpoint sp "\nSelect End Point : "))
      (plintav ss)
      (setq ss1 (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex ss))))
      (setq ss2 ss1)
      (if (not (setq plstart (car (nentselp sp))))
        (setq plstart (ssname (ssget "_C" (trans sp 1 0) (trans sp 1 0)) 0))
      )
      (entupd plstart)
      (if (not (setq plend (car (nentselp ep))))
        (setq plend (ssname (ssget "_C" (trans ep 1 0) (trans ep 1 0)) 0))
      )
      (entupd plend)
      (setq sp (trans sp 1 plstart))
      (setq ep (trans ep 1 plend))
      (if (not (vl-some (function (lambda ( x ) (equal x (list (car sp) (cadr sp)) 1e-6))) (MR:GetVertices plstart)))
        (setq spf t)
      )
      (if (not (vl-some (function (lambda ( x ) (equal x (list (car ep) (cadr ep)) 1e-6))) (MR:GetVertices plend)))
        (setq epf t)
      )
      (setq spp (list (car sp) (cadr sp) (setq el (vla-get-elevation (vlax-ename->vla-object plstart)))))
      (setq epp (list (car ep) (cadr ep) el))
      (setq sppar (vlax-curve-getparamatpoint plstart (trans spp plstart 0)))
      (setq eppar (vlax-curve-getparamatpoint plend (trans epp plend 0)))
      (repeat (setq n (sslength ss))
        (setq e (ssname ss (setq n (1- n))))
        (entupd e)
        (setq nn (vla-get-normal (vlax-ename->vla-object e)))
        (if (or (not (zerop el)) (not (equal nn (list 0.0 0.0 1.0) 1e-6)))
          (progn
            (vla-put-elevation (vlax-ename->vla-object e) el)
            (vla-put-normal (vlax-ename->vla-object e) nn)
          )
        )
      )
      (setq opt 0)
      (setq sss (ssadd))
      (repeat 2
        (setq opt (1+ opt))
        (setq sp spp ep epp)
        (setq pts+buls (PlPath-foo opt plstart (if (= opt 1) ss1 ss2) spf sppar epf eppar plstart plend))
        (setq e
          (entmakex
            (append
              (list
                (cons 0 "LWPOLYLINE")
                (cons 100 "AcDbEntity")
                (cons 100 "AcDbPolyline")
                (cons 38 el)
                (cons 90 (length (car pts+buls)))
                (cons 70 (* 128 (getvar (quote plinegen))))
              )
              (apply (function append) (mapcar (function (lambda ( p b ) (list (cons 10 p) (cons 42 b)))) (car pts+buls) (cadr pts+buls)))
              (list (cons 210 (safearray-value (variant-value nn))))
            )
          )
        )
        (ssadd e sss)
      )
      (vl-cmdf "_.erase" ss "")
      (vl-cmdf "_.pasteclip" (list 0.0 0.0 0.0))
      (vl-cmdf "_.draworder" sss "" "_f")
    )
  )
  (*error* nil)
)

 

HTH.

M.R.

Hola Marko, tiene el osmode en 513 y solo le cambié el osmode a 45 y ya la rutina no trabaja.
Cómo puedo solucionarlo, para poder trabajar solo con osmode 45 por favor ?
Gracias !!
Hello Marko, it has the osmode at 513 and I only changed the osmode to 45 and the routine no longer works. How can I solve it, so I can only work with osmode 45 please? Thank you !!

Edited Monday at 03:33 PM by duke

[marko_ribar]

I've modified it finally, I hope...

It's posted in my previous post...

It should work with any OSMODE as long as you pick points on LWPOLYLINE(s)...

 

Regards, M.R.

[duke]

43 minutes ago, marko_ribar said:

I've modified it finally, I hope...

It's posted in my previous post...

It should work with any OSMODE as long as you pick points on LWPOLYLINE(s)...

 

Regards, M.R.

Marko, excellent!!! Now it no longer gives an error when changing the OSMODE.
Thanks a lot !!!

[marko_ribar]

I was thinking... This code from @Steven P is also good... I just took some spare time to mod. it to suit my needs... Carefully read (alert) comment and you are ready to go testing it... All the best to author and others reading post...

 

(defun c:PlPath-single ( / *error* LSTrimToPt cmd osm ss Route rx uf TrimmedRoute PtA PtB )

  (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com))

  (defun *error* ( m )
    (if uf
      (if command-s
        (command-s "_.ucs" "_p")
        (vl-cmdf "_.ucs" "_p")
      )
    )
    (if (= 8 (logand 8 (getvar (quote undoctl))))
      (if command-s
        (command-s "_.undo" "_e")
        (vl-cmdf "_.undo" "_e")
      )
    )
    (if osm
      (setvar (quote osmode) osm)
    )
    (if cmd
      (setvar (quote cmdecho) cmd)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun LSTrimToPt ( MyLine TrimPt1 TrimPt2 / Pt1Dist Pt2Dist TempPt MyLineA MyLineB )

    (defun breakatpoint ( MyEnt point )
      (command "_.break" MyEnt "_non" point "_non" point)
    )

    (if command-s
      (command-s "_.zoom" "_ob" MyLine "")
      (vl-cmdf "_.zoom" "_ob" MyLine "")
    )
    (vla-ZoomScaled (vlax-get-acad-object) 0.95 acZoomScaledRelative)     ;; Zoom out a bit

    ;;sort trimpts according to distance from end A
    (setq Pt1Dist (vlax-curve-getdistatpoint MyLine TrimPt1))
    (setq Pt2Dist (vlax-curve-getdistatpoint MyLine TrimPt2))

    (if (> Pt1Dist Pt2Dist) ; swap trim points over
      (progn
        (setq TempPt TrimPt1)
        (setq TrimPt1 TrimPt2)
        (setq TrimPt2 TempPt)
      ) ;end progn
    ) ;end if

    (breakatpoint MyLine (trans TrimPt1 0 1))
    (setq MyLineA (entlast))

    (if (equal MyLineA MyLine 0.0001)
      (progn ; if end A is trim point
        (breakatpoint MyLine (trans TrimPt2 0 1))
        (setq MyLineB (entlast))
        (if (not (equal MyLineB MyLine 0.0001)) ; if end B is trim point
          (entdel MyLineB)
        )
      )
      (progn
        (entdel MyLine)
        (breakatpoint MyLineA (trans TrimPt2 0 1))
        (setq MyLineB (entlast))
        (if (not (equal MyLineB MyLineA 0.0001)) ; if end B is trim point
          (entdel MyLineB)
        )
      )
    ) ; end if

    MyLineA
  )

  (alert "If you want trimming on opposite side, you should change initial vertex of LWPOLYLINE (if your reference object is LWPOLYLINE) - use (c:chiv) if you have it loaded...")
  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (setq osm (getvar (quote osmode)))
  (setvar (quote osmode) 545)
  (if (= 8 (logand 8 (getvar (quote undoctl))))
    (if command-s
      (command-s "_.undo" "_e")
      (vl-cmdf "_.undo" "_e")
    )
  )
  (if command-s
    (command-s "_.undo" "_m")
    (vl-cmdf "_.undo" "_m")
  )
  (prompt "Select Line / PolyLine / Spline / HELIX on unlocked layer...")
  (if (setq ss (ssget "_+.:E:S:L" (list (cons 0 "*POLYLINE,SPLINE,HELIX,LINE"))))
    (progn
      (setq Route (ssname ss 0))
      (if
        (or
          (if (assoc 210 (setq rx (entget Route)))
            (not (equal (cdr (assoc 210 rx)) (list 0.0 0.0 1.0) 1e-6))
          )
          (if (assoc 38 rx)
            (not (zerop (cdr (assoc 38 rx))))
          )
        )
        (progn
          (if command-s
            (command-s "_.ucs" "_ob" Route)
            (vl-cmdf "_.ucs" "_ob" Route)
          )
          (setq uf t)
        )
        (if (= 0 (getvar (quote worlducs)))
          (progn
            (if command-s
              (command-s "_.ucs" "_w")
              (vl-cmdf "_.ucs" "_w")
            )
            (setq uf t)
          )
        )
      )
      (setq PtA (getpoint "Select Start point : "))
      (setq PtB (getpoint PtA "Select End point : "))
      (if (= 0 (getvar (quote worlducs)))
        (progn
          (setq PtA (trans PtA 1 0))
          (setq PtB (trans PtB 1 0))
        )
      )
      (setq TrimmedRoute (entmakex rx)) ; Copy route
      (setq TrimmedRoute (LSTrimToPt TrimmedRoute PtA PtB))
      (repeat 2
        (if command-s
          (command-s "_.zoom" "_p")
          (vl-cmdf "_.zoom" "_p")
        )
      )
      (if command-s
        (command-s "_.draworder" (ssadd TrimmedRoute) "" "_f")
        (vl-cmdf "_.draworder" (ssadd TrimmedRoute) "" "_f")
      )
    )
  )
  (*error* nil)
)

 

HTH.

Regards, M.R.

Edited Wednesday at 05:06 PM by marko_ribar

[duke]

57 minutes ago, marko_ribar said:

I was thinking... This code from @Steven P is also good... I just took some spare time to mod. it to suit my needs... Carefully read (alert) comment and you are ready to go testing it... All the best to author and others reading post...

 

(defun c:PlPath-single ( / *error* LSTrimToPt cmd osm ss Route rx uf TrimmedRoute PtA PtB )

  (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com))

  (defun *error* ( m )
    (if uf
      (if command-s
        (command-s "_.ucs" "_p")
        (vl-cmdf "_.ucs" "_p")
      )
    )
    (if (= 8 (logand 8 (getvar (quote undoctl))))
      (if command-s
        (command-s "_.undo" "_e")
        (vl-cmdf "_.undo" "_e")
      )
    )
    (if osm
      (setvar (quote osmode) osm)
    )
    (if cmd
      (setvar (quote cmdecho) cmd)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun LSTrimToPt ( MyLine TrimPt1 TrimPt2 / MyLineDef MyLineEndA MyLineEndB Pt1Dist Pt2Dist TempPt MyLineA MyLineB currentzoom )

    (defun breakatpoint ( MyEnt point )
      (command "_.break" MyEnt "_non" point "_non" point)
    )

    (if command-s
      (command-s "_.zoom" "_ob" MyLine "")
      (vl-cmdf "_.zoom" "_ob" MyLine "")
    )
    (vla-ZoomScaled (vlax-get-acad-object) 0.95 acZoomScaledRelative)     ;; Zoom out a bit
    (setq MyLineDef (entget MyLine))                                  ;; Get polyline entity definition
    (setq MyLineEndA (cdr (assoc 10 MyLineDef)))                      ;; Get the points of the line
    (if (= (cdr (assoc 0 MyLineDef)) "LINE")                          ;; Get end points of line / polyline
      (setq MyLineEndB (cdr (assoc 11 MyLineDef)))
      (setq MyLineEndB (cdr (assoc 10 (reverse MyLineDef))))
    )

    ;;sort trimpts according to distance from end A
    (setq Pt1Dist (vlax-curve-getdistatpoint (vlax-ename->vla-object MyLine) TrimPt1))
    (setq Pt2Dist (vlax-curve-getdistatpoint (vlax-ename->vla-object MyLine) TrimPt2))

    (if ( > Pt1Dist Pt2Dist) ; swap trim points over
      (progn
        (setq TempPt TrimPt1)
        (setq TrimPt1 TrimPt2)
        (setq TrimPt2 TempPt)
      ) ;end progn
    ) ;end if

    (breakatpoint MyLine TrimPt1)
    (setq MyLineA (entlast))

    (if (equal MyLineA MyLine 0.0001)
      (progn ; if end A is trim point
        (breakatpoint MyLine TrimPt2)
        (setq MyLineB (entlast))
        (if (not (equal MyLineB MyLine 0.0001)) ; if end B is trim point
          (entdel MyLineB)
        )
      )
      (progn
        (entdel MyLine)
        (breakatpoint MyLineA TrimPt2)
        (setq MyLineB (entlast))
        (if (not (equal MyLineB MyLineA 0.0001)) ; if end B is trim point
          (entdel MyLineB)
        )
      )
    ) ; end if

    MyLineA
  )

  (alert "If you want trimming on opposite side, you must change initial vertex of LWPOLYLINE - use (c:chiv) if you have it loaded, and starting point must have lower parameter than ending point...")
  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (setq osm (getvar (quote osmode)))
  (setvar (quote osmode) 545)
  (if (= 8 (logand 8 (getvar (quote undoctl))))
    (if command-s
      (command-s "_.undo" "_e")
      (vl-cmdf "_.undo" "_e")
    )
  )
  (if command-s
    (command-s "_.undo" "_m")
    (vl-cmdf "_.undo" "_m")
  )
  (prompt "Select Line / PolyLine / Spline on unlocked layer...")
  (if (setq ss (ssget "_+.:E:S:L" (list (cons 0 "*POLYLINE,SPLINE,LINE"))))
    (progn
      (setq Route (ssname ss 0))
      (if
        (or
          (if (assoc 210 (setq rx (entget Route)))
            (not (equal (cdr (assoc 210 rx)) (list 0.0 0.0 1.0) 1e-6))
          )
          (if (assoc 38 rx)
            (not (zerop (cdr (assoc 38 rx))))
          )
        )
        (progn
          (if command-s
            (command-s "_.ucs" "_ob" Route)
            (vl-cmdf "_.ucs" "_ob" Route)
          )
          (setq uf t)
        )
        (if (= 0 (getvar (quote worlducs)))
          (progn
            (if command-s
              (command-s "_.ucs" "_w")
              (vl-cmdf "_.ucs" "_w")
            )
            (setq uf t)
          )
        )
      )
      (setq PtA (getpoint "Select trim point 1 : "))
      (setq PtB (getpoint "Select trim point 2 : "))
      (setq TrimmedRoute (entmakex rx)) ; Copy route
      (setq TrimmedRoute (LSTrimToPt TrimmedRoute PtA PtB))
      (repeat 2
        (if command-s
          (command-s "_.zoom" "_p")
          (vl-cmdf "_.zoom" "_p")
        )
      )
      (if command-s
        (command-s "_.draworder" (ssadd TrimmedRoute) "" "_f")
        (vl-cmdf "_.draworder" (ssadd TrimmedRoute) "" "_f")
      )
    )
  )
  (*error* nil)
)

 

HTH.

Regards, M.R.

Hi Marko, this one also works perfectly and I changed the osmode to 45, and it also works perfectly.
Excellent !!!!