Draw polyline along with 2 or more adjacent closed polylines

[pBe]

Final version...

 

Almost but not quite. I'll have a look-see later Marko. but initials tests fails on some cases.

 

If i were to code this again I'll probably write a program form scratch.

 

Nevertheless, I'm glad you had it sorted.

 

EDIT: I tried the final code today, it appears to be working fine. Reason why it "failed" before its because of UCS. but its a small issue though

 

A quick re-write: [straight segments]

(Defun c:plpath2 (/ blg _swappost LM:ListClockwise-p p1 p2 data i p2p opt func pline_)
(defun blg (ent num / blg)
   (repeat num
     (setq blg	(cons (list (trans (vlax-safearray->list
			 (variant-value  (vla-Get-coordinate ent (setq num (1- num)))
			 )) 0 1)(vla-getbulge ent num)
	      )
	      blg
	)
     )
   )
 )
(defun _swappost (m ls md / a i c)
 (if (setq i -1 
           a (member m (cdr ls)))
   (repeat (setq n (- (length ls) (length a)))
     (if md
     	(setq a (append a (list (nth (setq i (1+ i)) ls))))
       (setq c (append c (list (nth (setq i (1+ i)) ls)))))
   ) ls
 )
)  
 (defun LM:ListClockwise-p ( lst )
   (minusp 
     (apply '+ 
       (mapcar
         (function
           (lambda ( a b )
             (- (* (car b) (cadr a)) (* (car a) (cadr b)))
           )
         ) lst (cons (last lst) lst)
       )
     )
   )
 )
 	(setq  p1 (getpoint "\nPick Start point: "))
 	(setq  p2 (getpoint p1 "\nPick End point: "))
 	(prompt "\nSelect Polylines:")
 	(setq data nil ss (ssget '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 0) )))
(repeat (setq i (sslength ss))
         	(setq data (cons
                            (progn 
                        (setq a  (blg (vlax-ename->vla-object (ssname ss (setq i (1- i) ))) ;prep for bulge
                                (cdr (assoc 90 (entget (ssname ss i)))))
                           )
                              (list a
                              (Caar (vl-sort (mapcar 'car a)
                                            '(lambda (j k) (< (car j)(car k)))))))
                             data )
               )
         )
(setq data (mapcar 'car (vl-sort data
                          '(lambda (j k) (< (last j)(last k)))))) 
(initget 1 "T B")
(setq opt (getkword "\nSelect option [Top/Bottom]: "))
 	(setq func (if (eq "T" opt); Clockwise
               '(LM:ListClockwise-p (mapcar 'car dr))
             	'(not (LM:ListClockwise-p (mapcar 'car dr)))
        ))
(setq data  (mapcar '(lambda (dr)
                                  (if (eval func)
                                    dr (reverse dr))) data))
       (setq p2p (mapcar '(lambda (x)
                                      	(mapcar 'car x)) data))

(setq plinedata (apply 'append (mapcar '(lambda (a b)
                                  (setq a (_swappost p1 a t))
                                  (setq _inter (vl-some '(lambda (p)
                           	            (if (member p b) p )) a))
                                  (setq p1 _inter)
                                  (_swappost _inter a nil))
                               p2p (cdr p2p))))
 	(setq a (_swappost p1 (last p2p) t ))
 	(setq lst (apply 'append (list plinedata (_swappost p2 a nil) (list p2))))
(setq pline_  
    (entmakex (append (list (cons 0 "LWPOLYLINE")
                          (cons 100 "AcDbEntity")
                          (cons 100 "AcDbPolyline")
                          (cons 90 (length lst))
                            )
                    (mapcar (function (lambda (p) (cons 10 p))) lst))))
 (sssetfirst nil (ssadd (entlast)))
 	(princ)
 )

Edited May 27, 2013 by pBe

[marko_ribar]

Hi pBe... Thanks for testing, I haven't noticed UCS issue, but I've modified my last final version to include old-heavy polylines, and reversed order of vertices for polylines that were reversed during this process...

 

(defun c:PlPath ( / rlw AssocOn LM:ListClockwise-p MR:GetVertices MR:GetBulge _intl prelst suflst _Buildlist
                   sp ep ss opt i pl hpllst rpllst pll a b bb ab lst lstab Pls 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 LM:ListClockwise-p ( lst )
   (minusp 
     (apply '+ 
       (mapcar
         (function
           (lambda ( a b )
             (- (* (car b) (cadr a)) (* (car a) (cadr b)))
           )
         ) lst (cons (last lst) lst)
       )
     )
   )
 )

 (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 (LM:ListClockwise-p (MR:GetVertices pl)))
           (progn
             (setq rpllst (cons pl rpllst))
             (rlw pl)
           )
         )
         (if (LM: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 (LM: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 (LM: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)
     (setq lst (reverse lst) lstab (reverse lstab))
     (while (< (setq i (1+ i)) (length lst))
       (setq Pls (_Buildlist (setq sp (list (car sp) (cadr sp))) (nth i lst)))
       (if (nth (1+ i) lst)
         (setq sp (car (_intl Pls (nth (1+ i) lst))))
         (setq sp (list (car ep) (cadr ep)))
       )
       (setq Pls (prelst Pls sp))
       (setq PtlSt (append PtlSt Pls))
     )
     (setq PtlSt (append PtlSt (list (list (car ep) (cadr ep)))))
     (foreach pt PtlSt
       (if (assoc ep (car lstab))
         (setq PtBulg (cons (cdr (assocon pt (reverse (apply 'append (reverse lstab))) 'car 1e-6)) PtBulg))
         (setq PtBulg (cons (cdr (assocon pt (reverse (apply 'append lstab)) 'car 1e-6)) PtBulg))
       )
     )
     (mapcar '(lambda (x) (if (equal x nil) (setq PttBulg (cons 0.0 PttBulg)) (setq PttBulg (cons x PttBulg)))) PtBulg)
     (setq PtlSt (mapcar '(lambda (x) (list (car x) (cadr x))) PtlSt))
     (foreach pl rpllst
       (rlw pl)
     )
     (entmakex 
       (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)
)

 

Also changed c:plintav to be applicable for old-heavy polylines...

 

(defun c:plintav ( / intersobj1obj2 LM:Unique AT:GetVertices _reml member-fuzz add_vtx
                    ss sslpl sshpl i ent n ent1 ss-ent1 k ent2 intpts intptsall pl plpts restintpts par )

 (vl-load-com)

 (defun intersobj1obj2 ( obj1 obj2 / coords pt ptlst )
   (if (eq (type obj1) 'ENAME) (setq obj1 (vlax-ename->vla-object obj1)))
   (if (eq (type obj2) 'ENAME) (setq obj2 (vlax-ename->vla-object obj2)))
   (setq coords (vl-catch-all-apply 'vlax-safearray->list (list (vl-catch-all-apply 'vlax-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-6)
         (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
 )

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

 (setq ss (ssget "_:L" (list '(0 . "*POLYLINE") '(-4 . "<or") '(70 . 0) '(70 . 1) '(70 . 128) '(70 . 129) '(-4 . "or>") (cons 410 (if (= 1 (getvar 'cvport)) (getvar 'ctab) "Model")))))
 (setq sslpl (ssadd) sshpl (ssadd))
 (setq i -1)
 (while (setq ent (ssname ss (setq i (1+ i))))
   (if (eq (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
     (progn
       (entupd ent)
       (vla-update (vlax-ename->vla-object ent))
       (ssadd ent sslpl)
     )
   )
   (if (eq (cdr (assoc 0 (entget ent))) "POLYLINE")
     (ssadd ent sshpl)
   )
 )
 (setq i -1)
 (while (setq ent (ssname sshpl (setq i (1+ i))))
   (command "_.convertpoly" "l" ent "")
   (entupd ent)
   (vla-update (vlax-ename->vla-object ent))
   (ssadd ent sslpl)
 )
 (repeat (setq n (sslength ss))
   (setq ent1 (ssname ss (setq n (1- n))))
   (setq ss-ent1 (ssdel ent1 ss))
   (repeat (setq k (sslength ss-ent1))
     (setq ent2 (ssname ss-ent1 (setq k (1- k))))
     (setq intpts (intersobj1obj2 ent1 ent2))
     (setq intptsall (append intpts intptsall))
   )
 )
 (setq i -1)
 (while (setq pl (ssname sslpl (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 (vlax-ename->vla-object pl) par pl)        
     )
   )
 )
 (setq i -1)
 (while (setq ent (ssname sshpl (setq i (1+ i))))
   (command "_.convertpoly" "h" ent "")
 )
 (princ)
)

 

Edited March 29, 2023 by marko_ribar

[marko_ribar]

And also have searched for adding and removing vertex to and from polyline... It works also for LWPOLYLINE and old heavy POLYLINE...

 

(defun c:plav ( / add_vtx pt pl flag )
 
 (vl-load-com)
 
 (defun add_vtx ( obj add_pt ent_name / bulg sw ew )
     (vla-GetWidth obj (fix add_pt) 'sw 'ew)
     (vla-addVertex
         obj
         (1+ (fix add_pt))
         (vlax-make-variant
             (vlax-safearray-fill
                 (vlax-make-safearray vlax-vbdouble (cons 0 1))
                     (list
                         (car (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
                         (cadr (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
                     )
             )
         )
     )
     (setq bulg (vla-GetBulge obj (fix add_pt)))
     (vla-SetBulge obj
         (fix add_pt)
         (/
             (sin (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
             (cos (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
         )
     )
     (vla-SetBulge obj
         (1+ (fix add_pt))
         (/
             (sin (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
             (cos (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
         )
     )
     (vla-SetWidth obj (fix add_pt) sw (+ sw (* (- ew sw) (- add_pt (fix add_pt)))))
     (vla-SetWidth obj (1+ (fix add_pt)) (+ sw (* (- ew sw) (- add_pt (fix add_pt)))) ew)
     (vla-update obj)
 )
 
 (setq pl (car (entsel "\nSelect pline entity")))
 (if (not (wcmatch (cdr (assoc 0 (entget pl))) "*POLYLINE"))
   (progn
     (alert "\nPicked entity isn't polyline - quitting")
     (exit)
   )
   (if (and (not (< 7 (cdr (assoc 70 (entget pl))) 14)) (eq (cdr (assoc 0 (entget pl))) "POLYLINE"))
     (if (< (cdr (assoc 70 (entget pl))) 130)
       (progn
         (setq flag T)
         (command "_.convertpoly" "l" pl "")
       )
       (progn
         (alert "\nYou picked 2d polyline that can't be converted to LWPOLYLINE - quitting")
         (exit)
       )
     )
     (if (not (eq (cdr (assoc 0 (entget pl))) "LWPOLYLINE"))
       (progn
         (alert "\nYou picked 3d polyline - quitting")
         (exit)
       )
     )
   )
 )
 (while
   (setq pt (getpoint "\nPick point where you want to add vertex to pline - please HIT ENTER to properly end routine"))
   (setq pt (trans pt 1 0))
   (add_vtx (vlax-ename->vla-object pl) (vlax-curve-getparamatpoint pl (vlax-curve-getclosestpointto pl pt)) pl)
 )
 (if flag
   (command "_.convertpoly" "h" pl "")
 )
 (princ)
)

 

(defun c:pldv ( / AssocOn tang prelst suflst 
                 osm pl flag pt par bul ptp parp bulp ptn parn a1 a2 r1 r2 c1 c2 bulpn pll pllp plls plll )

 (vl-load-com)

 (defun AssocOn ( SearchTerm Lst func fuzz )
   (car
     (vl-member-if
       (function
         (lambda (pair) (equal SearchTerm (apply func (list pair)) fuzz))
       )
       lst
     )
   )
 )

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

 (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))
 )
 
 (setq osm (getvar 'osmode))
 (setq pl (car (entsel "\nPick pline entity")))
 (if (not (wcmatch (cdr (assoc 0 (entget pl))) "*POLYLINE"))
   (progn
     (alert "\nPicked entity isn't polyline - quitting")
     (exit)
   )
   (if (and (not (< 7 (cdr (assoc 70 (entget pl))) 14)) (eq (cdr (assoc 0 (entget pl))) "POLYLINE"))
     (if (< (cdr (assoc 70 (entget pl))) 130)
       (progn
         (setq flag T)
         (command "_.convertpoly" "l" pl "")
       )
       (progn
         (alert "\nYou picked 2d polyline that can't be converted to LWPOLYLINE - quitting")
         (exit)
       )
     )
     (if (not (eq (cdr (assoc 0 (entget pl))) "LWPOLYLINE"))
       (progn
         (alert "\nYou picked 3d polyline - quitting")
         (exit)
       )
     )
   )
 )
 (setvar 'osmode 1)
 (while (setq pt (getpoint "\nPick vertex to remove - please HIT ENTER to properly end routine"))
   (setq pt (trans pt 1 0))
   (setq par (vlax-curve-getparamatpoint pl (vlax-curve-getclosestpointto pl pt)))
   (setq pt (trans pt 0 pl))
   (setq bul (cdr (assoc 42 (member (assocon (reverse (cdr (reverse pt))) (entget pl) 'cdr 1e-6) (entget pl)))))
   (if (and (not (equal par (vlax-curve-getstartparam pl) 1e-6)) (not (equal par (vlax-curve-getendparam pl) 1e-6)))
     (progn
       (setq parp (- par 1.0))
       (setq ptp (vlax-curve-getpointatparam pl parp))
       (setq ptp (trans ptp 0 pl))
       (setq bulp (cdr (assoc 42 (member (assocon (reverse (cdr (reverse ptp))) (entget pl) 'cdr 1e-6) (entget pl)))))
       (if (/= bulp 0.0)
         (progn
           (setq a1 (* 4.0 (atan bulp)))
           (setq r1 (/ (distance ptp pt) (* 2 (sin (* 2 (atan bulp))))))
           (setq c1 (polar ptp (+ (angle ptp pt) (- (/ pi 2.0) (* 2 (atan bulp)))) r1))
           (if (/= bul 0.0)
             (progn
               (setq parn (+ par 1.0))
               (setq ptn (vlax-curve-getpointatparam pl parn))
               (setq ptn (trans ptn 0 pl))
               (setq a2 (* 4.0 (atan bul)))
               (setq r2 (/ (distance pt ptn) (* 2 (sin (* 2 (atan bul))))))
               (setq c2 (polar pt (+ (angle pt ptn) (- (/ pi 2.0) (* 2 (atan bul)))) r2))
               (if (and (equal r1 r2 1e-6) (equal c1 c2 1e-6))
                 (setq bulpn (tang (/ (+ a1 a2) 4.0)))
               )
             )
             (setq bulpn 0.0)
           )
         )
         (setq bulpn 0.0)
       )
     )
     (progn
       (alert "\nPicked vertex is start-end vertex of pline and can't be removed - quitting")
       (exit)
     )
   )
   (setq pll (entget pl))
   (setq pll (append (prelst pll (assocon (reverse (cdr (reverse pt))) pll 'cdr 1e-6)) (cdddr (suflst pll (assocon (reverse (cdr (reverse pt))) pll 'cdr 1e-6)))))
   (setq pllp (prelst pll (assocon (reverse (cdr (reverse ptp))) pll 'cdr 1e-6)))
   (setq plls (suflst pll (assocon (reverse (cdr (reverse ptp))) pll 'cdr 1e-6)))
   (setq plls (subst (cons 42 bulpn) (assoc 42 plls) plls))
   (setq plll (append pllp (list (assocon (reverse (cdr (reverse ptp))) pll 'cdr 1e-6)) plls))
   (entmod plll)
   (entupd (cdr (assoc -1 plll)))
 )
 (setvar 'osmode osm)
 (if flag
   (command "_.convertpoly" "h" pl "")
 )
 (princ)
)

 

Edited March 29, 2023 by marko_ribar

[marko_ribar]

All my last 4 codes should work in any UCS and with any polyline entity type...

 

Regards, M.R.

[marko_ribar]

Since I've test my codes and they didn't fail in any situations, no matter what orientation of plines and UCS, if they are connected 2 by 2 and are in the same plane, PlPath.lsp won't fail... So, I decided to post these my 4 codes for pline manipulations in one *.zip, since I won't modify them further more...

 

Sincerely, your M.R.

 

[EDIT : ZIP was reattached due to mistake in filtering "POLYLINE" entities in codes plintav.lsp, plav.lsp and pldv.lsp... It were 13+24(1st reattach) downloads till ZIP was reattached again... - Note that these 3 LSP files I mentioned won't work correct if old heavy polyline changed its smoothness (fit/quadratic/cubic)]

 

[EDIT : New ZIP : PLINETOOLS BY MR+GC+LM.ZIP contains :

 

chiv.lsp

clpls.lsp

convseglws2arcedlws.lsp

cseglws2lws.lsp

cseglws2lws-lins-b.lsp

lws-arcs-seg.lsp (renamed pline-arcs-seg.lsp)

lws-arcs-seg-b.lsp

lws-arcs-seg-d.lsp

lws-arcs-seg-d-b.lsp

lws-lins-seg.lsp

lws-lins-seg-d.lsp

lws-segs-seg.lsp

lws-segs-seg-b.lsp

lws-segs-seg-d.lsp

lws-segs-seg-d-b.lsp

plav.lsp

pldv.lsp

plintav-new.lsp

plintav.lsp

PlPath.lsp

SLWS.lsp

 

It had to be reattached, since numerous modifications among which PlPath.lsp was one... The codes posted are correct, but I suggest that you download archive - not to surf to all this posted links and do copy+paste into notepad... [/EDIT]

 

[EDIT : New addition to PLINETOOLS with additional 3 lisps can be found here :

http://www.cadtutor.net/forum/showthread.php?67924-Draw-polyline-along-with-2-or-more-adjacent-closed-polylines/page4&p=#40

[/EDIT]

PLINETOOLS BY MR+GC+LM.zip

Edited March 3, 2016 by marko_ribar
reattached ZIP and reattached ZIP again...

[marko_ribar]

Codes changed and updated...

 

ZIP was reattached due to mistake in filtering "POLYLINE" entities in codes plintav.lsp, plav.lsp and pldv.lsp...

 

M.R.

[marko_ribar]

After my little vacation, I've updated plpath.lsp to accept returning back path around plines that are in linear disposition... I am afraid that for areal disposition it's impossible for routine to determine correct array of selected plines and therefore only this way it'll work... For this kind of situations I strongly suggest that you do it step by step (one by one plpath), or even better if you want complete boundary, then use BPOLY command... In addition to my updated plpath.lsp that can be used with my plintav.lsp I'll post my chiv.lsp (change initial vertex) - this one is useful if you want to remove start/ending segment of polyline - use it in combination with pldv.lsp...

 

Kind regards, M.R.

 

(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)
)

 

(defun c:CHIV ( / osm ss e f ed edd eddd eddd1 eddd2 eddd3 newed p m n i )

 (vl-load-com)

 (setq osm (getvar 'osmode))
 (setvar 'osmode 1)
 (prompt "\nPick closed 2d polyline with or without arcs")
 (setq ss (ssget "_+.:E:S:L" '((0 . "*POLYLINE") (-4 . "<or") (70 . 1) (70 . 129) (-4 . "or>"))))
 (if ss
   (setq e (ssname ss 0))
   (progn
     (setvar 'osmode osm)
     (alert "Picked wrong entity... Please pick normal closed 2d polyline next time-quitting...")
     (exit)
   )
 )
 (if (eq (cdr (assoc 0 (entget e))) "POLYLINE")
   (progn
     (setq f t)
     (command "_.convertpoly" "_l" e "")
   )
 )
 (setq ed (entget e))
 (setq edd nil)
 (foreach ec ed 
   (if (not 
         (or (eq (car ec) 10) (eq (car ec) 40) (eq (car ec) 41) (eq (car ec) 42) (eq (car ec) 91) (eq (car ec) 210))
       )
       (setq edd (cons ec edd))
   )
 )
 (setq edd (reverse edd))
 (setq eddd nil)
 (setq eddd1 nil)
 (setq eddd2 nil)
 (setq eddd (member (assoc 10 ed) ed))
 (setq p (getpoint "\nPick vertex you want to become initial"))
 (setq m (vlax-curve-getparamatpoint e (vlax-curve-getclosestpointto e p)))
 (if (assoc 91 ed) (setq n (* m 5)) (setq n (* m 4)))
 (setq i 0)
 (foreach ec eddd
   (progn
     (setq i (+ i 1))
     (if (<= i n)
       (setq eddd1 (cons ec eddd1))
     )
     (if (> i n)
       (setq eddd2 (cons ec eddd2))
     )
   )
 )
 (setq eddd1 (reverse eddd1))
 (setq eddd3 (list (assoc 210 eddd2)))
 (setq eddd2 (cdr eddd2))
 (setq eddd2 (reverse eddd2))
 (setq newed (append edd eddd2 eddd1 eddd3))
 (entmod newed)
 (entupd e)
 (setvar 'osmode osm)
 (if f
   (command "_.convertpoly" "_h" e "")
 )
 (alert "After CHIV, run PEDIT->Edit Vertex to see change")
 (princ)
)

 

Edited March 29, 2023 by marko_ribar

[marko_ribar]

 

Regards, M.R.

[marko_ribar]

New plintav-new.lsp can be found here :

 

http://www.cadtutor.net/forum/showthread.php?88256-lisp-for-multi-trim-and-extend-with-condition

 

M.R.

[marko_ribar]

I want to mention that I systematized my PLINETOOLS... I have to give credits to Mr. Lee Mac and Mr. Gilles Chanteau for their helpful subfunctions and clpls.lsp by Gilles...

 

You can download archive here :

http://www.cadtutor.net/forum/showthread.php?67924-Draw-polyline-along-with-2-or-more-adjacent-closed-polylines/page3&p=#25

 

P.S. Had to reattach archive, cos it happened numerous mods. meanwhile among which is PlPath.lsp which is the main routine...

 

Regards, M.R.

[marko_ribar]

I've realized that I wrongly named "pline-arcs-seg.lsp" and forgot to add "lws-segs-seg.lsp" and "lws-segs-seg-d.lsp"... See my updated "PLINETOOLS BY MR+GC+LM.ZIP" and description posted on that post...

 

Sorry for inconvenience...

Hope that now its all OK...

Regards, M.R.

Edited November 8, 2014 by marko_ribar

[marko_ribar]

Also added bulges versions of "lws-*-segs*-b.lsp"

 

Now if you want, only thing is to do segmentation of just line segments, but this case isn't so important... If you want some transformations to perform you have segmentation of complete lwpolylines and just arcs on them, I just don't see where would you use just line segments segmentation...

 

So long from me... M.R.

[marko_ribar]

Now if you want, only thing is to do segmentation of just line segments, but this case isn't so important... If you want some transformations to perform you have segmentation of complete lwpolylines and just arcs on them, I just don't see where would you use just line segments segmentation...

 

I've added and "lws-lins-seg.lsp" and "lws-lins-seg-d.lsp"

I think that's all... No more combinations, all are there...

 

Regards...

[marko_ribar]

Added new "cseglws2lws.lsp" and "cseglws2lws-lins-b.lsp"...

 

I hope you'll like it, there were 6 downloads till I reattached ZIP...

 

Regards, M.R.

Edited November 7, 2014 by marko_ribar

[marko_ribar]

Added - simplify lwpolyline(s) : SLWS.lsp by Gilles Chanteau... I think it's better than my version cseglws2lws-lins-b.lsp...

 

Regards, M.R.

[marko_ribar]

There was a mistake in condtitions for "cseglws2lws.lsp" and "cseglws2lws-lins-b.lsp" when the last segment of the polyline is line with one vertex between ... Now it's settled, otherwise the advice is you should be using a SLWS.lsp (simplify LWPOLYLINES) by Gilles Chanteau if you have one vertex in the arced segments of polylines; if you have min. two vertices on the arced parts then you can feel free to use "cseglws2lws.lsp" and "cseglws2lws-lins-b.lsp" ... "cseglws2lws.lsp" is used for obtaining the simplified polyline from those arising from "lws-*-seg-(d).lsp" and "cseglws2lws-lins-b.lsp" is used for the same than those created with "lws-*-seg-(d)-b.lsp " or segmented only line segments of "lws-lins-seg-(d).lsp"... ZIP has been reattached... Sorry for inconvenience, it was just very small issue and it would be arrisen only if segmentation is manually created...

 

Regards, M.R.

[hanhphuc]

Thanks for sharing Marko.

post #25 is the latest update?

 

regards,

hanhphuc

[marko_ribar]

Thanks for sharing Marko.

post #25 is the latest update?

 

regards,

hanhphuc

 

Yes, post #25 is the latest update...

[mailmaverick]

Hi Marko

 

Thanks for attaching PLINETOOLS BY MR+GC+LM.ZIP in Post No 25.

 

However, in many of the LISPS, description is not given about what it does.

 

Can you please make a brief one line description of what each LISP routine does ?

 

Thanks a lot.

[marko_ribar]

My latest addition to PLINETOOLS archive... ( 3 missing lisps ... )

 

They'll divide LWPOLYLINE with equal distances, but make divisions center viewing from each segment of polyline (ending segments may be different than division unit distance, but equal at each end side of segment)...

 

M.R.

lws-lins-seg-d-new.lsp

lws-segs-seg-d-new.lsp

lws-arcs-seg-d-new.lsp