Draw polyline along with 2 or more adjacent closed polylines

[marko_ribar]

New "plintav-opt.lsp" can be found here posted in code tags :

http://www.cadtutor.net/forum/showthread.php?96478-How-to-delete-one-line-from-each-joint&p=659455#post659455

 

Regards, M.R.

[marko_ribar]

Two more lisps - or you can load them both...

 

(defun c:lwint2bulge ( / *error* clean_poly mid clockwise-p *adoc* osm p lw p1 p2 lwx dxf10 a c1 c2 r1 r2 c dxf10n pn r b gr )

 (vl-load-com)

 (defun *error* ( m )
   (if osm
     (setvar 'osmode osm)
   )
   (clean_poly lw)
   (vla-endundomark *adoc*)
   (if m
     (prompt m)
   )
   (princ)
 )

 (defun clean_poly ( ent / trunc e_lst p_lst )

   (defun trunc ( expr lst )
     (if (and lst (not (equal (car lst) expr 1e-6)))
       (cons (car lst) (trunc expr (cdr lst)))
     )
   )

   (setq e_lst (entget ent))
   (if (= "LWPOLYLINE" (cdr (assoc 0 e_lst)))
     (progn
       (setq p_lst 
                   (vl-remove-if-not 
                    '(lambda (x)
                       (or (= (car x) 10)
                           (= (car x) 40)
                           (= (car x) 41)
                           (= (car x) 42)
                       )
                     )
                     e_lst
                   )
             e_lst 
                   (vl-remove-if
                    '(lambda (x)
                       (member x p_lst)
                     )
                     e_lst
                   )
       )
       (if (= 1 (logand (cdr (assoc 70 e_lst)) 1))
         (while (equal (car p_lst) (assoc 10 (reverse p_lst)))
           (setq p_lst (reverse (cdr (member (assoc 10 (reverse p_lst)) (reverse p_lst)))))
         )
       )
       (while p_lst
         (setq e_lst (append e_lst (trunc (assoc 10 (cdr p_lst)) p_lst))
               p_lst (member (assoc 10 (cdr p_lst)) (cdr p_lst))
         )
       )
       (entmod e_lst)
     )
   )
   (princ)
 )

 (defun mid ( p1 p2 )
   (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
 )

 (defun clockwise-p ( p1 p p2 )
   (minusp (- (* (car (mapcar '- p p1)) (cadr (mapcar '- p p2))) (* (cadr (mapcar '- p p1)) (car (mapcar '- p p2)))))
 )

 (vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
 (setq osm (getvar 'osmode))
 (setvar 'osmode 1)
 (setq p (getpoint "\nPick intersection vertex on LWPOLYLINE other than start/end vertex..."))
 (setq lw (ssname (ssget "_C" p p '((0 . "LWPOLYLINE"))) 0))
 (setq p1 (vlax-curve-getpointatparam lw (1- (vlax-curve-getparamatpoint lw (vlax-curve-getclosestpointto lw (trans p 1 0))))))
 (setq p2 (vlax-curve-getpointatparam lw (1+ (vlax-curve-getparamatpoint lw (vlax-curve-getclosestpointto lw (trans p 1 0))))))
 (setq lwx (entget lw))
 (setq dxf10 (cons 10 (mapcar '+ '(0.0 0.0) (trans p 1 lw))))
 (setq a (angle (trans p 1 lw) (mid (polar (trans p 1 lw) (angle (trans p 1 lw) (trans p1 0 lw)) 1.0) (polar (trans p 1 lw) (angle (trans p 1 lw) (trans p2 0 lw)) 1.0))))
 (setq c1 (inters (trans p1 0 lw) (polar (trans p1 0 lw) (+ (angle (trans p 1 lw) (trans p1 0 lw)) (* 0.5 pi)) 1.0) (trans p 1 lw) (polar (trans p 1 lw) a 1.0) nil))
 (setq c2 (inters (trans p2 0 lw) (polar (trans p2 0 lw) (+ (angle (trans p 1 lw) (trans p2 0 lw)) (* 0.5 pi)) 1.0) (trans p 1 lw) (polar (trans p 1 lw) a 1.0) nil))
 (setq r1 (distance c1 (trans p1 0 lw)))
 (setq r2 (distance c2 (trans p2 0 lw)))
 (if (< r1 r2)
   (setq c c1)
   (setq c c2)
 )
 (setq dxf10n (cons 10 (mapcar '+ '(0.0 0.0) (trans (setq pn (trans (polar (trans p 1 lw) (angle (trans p 1 lw) (trans (if (equal c1 c 1e-6) p2 p1) 0 lw)) (if (equal c1 c 1e-6) (distance (trans p 1 lw) (trans p1 0 lw)) (distance (trans p 1 lw) (trans p2 0 lw)))) lw 0)) 0 lw))))
 (setq lwx (subst dxf10n (car (vl-member-if '(lambda ( x ) (equal x dxf10 1e-6)) lwx)) lwx))
 (if (equal (distance (trans p1 0 lw) (trans p 1 lw)) (+ (distance (trans p1 0 lw) (trans pn 0 lw)) (distance (trans pn 0 lw) (trans p 1 lw))) 1e-6)
   (progn
     (setq r (distance c (trans p2 0 lw)))
     (entupd (cdr (assoc -1 (entmod lwx))))
     (prompt "\nMove mouse around center of view left/right or up/down to choose type of bulge...")
     (while (= 5 (car (setq gr (grread t))))
       (if (> (* (- (car (getvar 'viewctr)) (caadr gr)) (- (cadr (getvar 'viewctr)) (cadadr gr))) 0.0)
         (progn
           (setq b (/ (sin (/ (rem (+ pi pi (- (angle c (trans pn 0 lw)) (angle c (trans p2 0 lw)))) (+ pi pi)) 4.0)) (cos (/ (rem (+ pi pi (- (angle c (trans pn 0 lw)) (angle c (trans p2 0 lw)))) (+ pi pi)) 4.0))))
           (if (not (clockwise-p (trans pn 0 lw) c (trans p2 0 lw)))
             (if (> (abs b) 1.0)
               (setq b (- (abs b)))
               (setq b (abs b))
             )
             (if (< (abs b) 1.0)
               (setq b (- (abs b)))
               (setq b (abs b))
             )
           )
           (vla-setbulge (vlax-ename->vla-object lw) (vlax-curve-getparamatpoint lw pn) b)
         )
         (progn
           (setq b (/ (sin (/ (- (* 2.0 pi) (rem (+ pi pi (- (angle c (trans pn 0 lw)) (angle c (trans p2 0 lw)))) (+ pi pi))) 4.0)) (cos (/ (- (* 2.0 pi) (rem (+ pi pi (- (angle c (trans pn 0 lw)) (angle c (trans p2 0 lw)))) (+ pi pi))) 4.0))))
           (if (not (clockwise-p (trans pn 0 lw) c (trans p2 0 lw)))
             (if (> (abs b) 1.0)
               (setq b (- (abs b)))
               (setq b (abs b))
             )
             (if (< (abs b) 1.0)
               (setq b (- (abs b)))
               (setq b (abs b))
             )
           )
           (vla-setbulge (vlax-ename->vla-object lw) (vlax-curve-getparamatpoint lw pn) b)
         )
       )
     )
   )
   (progn
     (setq r (distance c (trans p1 0 lw)))
     (entupd (cdr (assoc -1 (entmod lwx))))
     (prompt "\nMove mouse around center of view left/right or up/down to choose type of bulge...")
     (while (= 5 (car (setq gr (grread t))))
       (if (> (* (- (car (getvar 'viewctr)) (caadr gr)) (- (cadr (getvar 'viewctr)) (cadadr gr))) 0.0)
         (progn
           (setq b (/ (sin (/ (rem (+ pi pi (- (angle c (trans p1 0 lw)) (angle c (trans pn 0 lw)))) (+ pi pi)) 4.0)) (cos (/ (rem (+ pi pi (- (angle c (trans p1 0 lw)) (angle c (trans pn 0 lw)))) (+ pi pi)) 4.0))))
           (if (not (clockwise-p (trans p1 0 lw) c (trans pn 0 lw)))
             (if (> (abs b) 1.0)
               (setq b (- (abs b)))
               (setq b (abs b))
             )
             (if (< (abs b) 1.0)
               (setq b (- (abs b)))
               (setq b (abs b))
             )
           )
           (vla-setbulge (vlax-ename->vla-object lw) (vlax-curve-getparamatpoint lw p1) b)
         )
         (progn
           (setq b (/ (sin (/ (- (* 2.0 pi) (rem (+ pi pi (- (angle c (trans p1 0 lw)) (angle c (trans pn 0 lw)))) (+ pi pi))) 4.0)) (cos (/ (- (* 2.0 pi) (rem (+ pi pi (- (angle c (trans p1 0 lw)) (angle c (trans pn 0 lw)))) (+ pi pi))) 4.0))))
           (if (not (clockwise-p (trans p1 0 lw) c (trans pn 0 lw)))
             (if (> (abs b) 1.0)
               (setq b (- (abs b)))
               (setq b (abs b))
             )
             (if (< (abs b) 1.0)
               (setq b (- (abs b)))
               (setq b (abs b))
             )
           )
           (vla-setbulge (vlax-ename->vla-object lw) (vlax-curve-getparamatpoint lw p1) b)
         )
       )
     )
   )
 )
 (*error* nil)
)

(defun c:lwbulge2int ( / *error* clean_poly add_vtx *adoc* osm p lw p1 p2 lwx b v1 v2 pn dxf10 dxf10n )

 (vl-load-com)

 (defun *error* ( m )
   (if osm
     (setvar 'osmode osm)
   )
   (clean_poly lw)
   (vla-endundomark *adoc*)
   (if m
     (prompt m)
   )
   (princ)
 )

 (defun clean_poly ( ent / trunc e_lst p_lst )

   (defun trunc ( expr lst )
     (if (and lst (not (equal (car lst) expr 1e-6)))
       (cons (car lst) (trunc expr (cdr lst)))
     )
   )

   (setq e_lst (entget ent))
   (if (= "LWPOLYLINE" (cdr (assoc 0 e_lst)))
     (progn
       (setq p_lst 
                   (vl-remove-if-not 
                    '(lambda (x)
                       (or (= (car x) 10)
                           (= (car x) 40)
                           (= (car x) 41)
                           (= (car x) 42)
                       )
                     )
                     e_lst
                   )
             e_lst 
                   (vl-remove-if
                    '(lambda (x)
                       (member x p_lst)
                     )
                     e_lst
                   )
       )
       (if (= 1 (logand (cdr (assoc 70 e_lst)) 1))
         (while (equal (car p_lst) (assoc 10 (reverse p_lst)))
           (setq p_lst (reverse (cdr (member (assoc 10 (reverse p_lst)) (reverse p_lst)))))
         )
       )
       (while p_lst
         (setq e_lst (append e_lst (trunc (assoc 10 (cdr p_lst)) p_lst))
               p_lst (member (assoc 10 (cdr p_lst)) (cdr p_lst))
         )
       )
       (entmod e_lst)
     )
   )
   (princ)
 )

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

 (vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
 (setq osm (getvar 'osmode))
 (setvar 'osmode 512)
 (setq p (getpoint "\nPick bulged segment on LWPOLYLINE..."))
 (setq lw (ssname (ssget "_C" p p '((0 . "LWPOLYLINE"))) 0))
 (setq p1 (vlax-curve-getpointatparam lw (float (fix (vlax-curve-getparamatpoint lw (vlax-curve-getclosestpointto lw (trans p 1 0)))))))
 (setq p2 (vlax-curve-getpointatparam lw (float (1+ (fix (vlax-curve-getparamatpoint lw (vlax-curve-getclosestpointto lw (trans p 1 0))))))))
 (setq lwx (entget lw))
 (setq b (vla-getbulge (vlax-ename->vla-object lw) (vlax-curve-getparamatpoint lw p1)))
 (setq v1 (vlax-curve-getfirstderiv lw (vlax-curve-getparamatpoint lw p1)))
 (setq v2 (vlax-curve-getfirstderiv lw (- (vlax-curve-getparamatpoint lw p2) 1e-15)))
 (setq pn (inters p1 (mapcar '+ p1 v1) p2 (mapcar '+ p2 v2) nil))
 (vla-setbulge (vlax-ename->vla-object lw) (vlax-curve-getparamatpoint lw p1) 0.0)
 (add_vtx (vlax-ename->vla-object lw) (+ (vlax-curve-getparamatpoint lw p1) 0.5) lw)
 (vla-setbulge (vlax-ename->vla-object lw) (1- (vlax-curve-getparamatpoint lw p2)) 0.0)
 (setq lwx (entget lw))
 (setq dxf10 (assoc 10 (cdr (vl-member-if '(lambda ( x ) (equal x (cons 10 (mapcar '+ '(0.0 0.0) (trans p1 0 lw))) 1e-6)) lwx))))
 (setq dxf10n (cons 10 (mapcar '+ '(0.0 0.0) (trans pn 0 lw))))
 (entupd (cdr (assoc -1 (entmod (subst dxf10n dxf10 lwx)))))
 (setvar 'osmode osm)
 (*error* nil)
)

M.R.

Edited May 2, 2016 by marko_ribar
code changed...

[marko_ribar]

Updated last posted code...

 

M.R.

[marko_ribar]

Now when I study this topic again it seems that I forgot to include those :

http://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/convert-polyline-line-segments-to-arc-segments/m-p/5814922/highlight/true#M335051

 

They also belong to PLINETOOLS although the kudos goes to Evgeniy Elpanov who introduced them in short variants working in WCS and then I revised them to be applicable in all situations...

[marko_ribar]

This could also be part of PLINETOOLS package...

http://www.cadtutor.net/forum/showthread.php?96590-Join-multiple-collinear-polylines&p=#7

 

M.R.

[marko_ribar]

This lisp is also possible to be inside PLINETOOLS... It is for offsetting LWPOLY segment with connection to boundary... Should work fine, just check for consistency of LWPOLY prior running routine... If there is some bug or lack please inform me...

 

Also I've found lack in Gille's (trunc) :

 (defun trunc ( expr lst )
   (if (and lst (not (equal (car lst) expr)))
     (cons (car lst) (trunc expr (cdr lst)))
   )
 )

Should be changed to something like this - allowing fuzz equality tolerance :

 (defun trunc ( expr lst )
   (if (and lst (not (equal (car lst) expr 1e-6)))
     (cons (car lst) (trunc expr (cdr lst)))
   )
 )

So please change this fix in every occurrence of (trunc) inside PLINETOOLS...

 

In attachment is lisp lwosegtd.lsp for offsetting segment...

lwosegtd.lsp

Edited May 2, 2016 by marko_ribar

[marko_ribar]

Reattached last posted lisp...

 

For those that downloaded it (2)... Add this fix at the end of lisp :

 

...
   )
 )
 (if (and lw1 (entget lw1) (not (equal lw1 (entlast))))
   (entdel lw1)
 )
 (if (and lw2 (entget lw2) (not (equal lw2 (entlast))))
   (entdel lw2)
 )
 (command "_.UCS" "_P")
 (*error* nil)
)

 

 

M.R. Sorry for this missed fix...

 

The most recent input ab PLINETOOLS is lwsdvts.lsp posted here :

https://www.theswamp.org/index.php?topic=58030.0

 

HTH.

M.R.

Edited March 29, 2023 by marko_ribar

[ajc]

Hi Marko,

 

I've tried a few of your tools and think they are quite good.

Is there any brief description of each of the tools? I've bumped into a youtube video that shows the use of a few but not all lot them.

 

If you could update the code with a description of what it does and version number plus release date it'd help a lot. I know this may sound like a nuisance. I'm usually on the side of the tool developing and have to admit that this is quite useful for people and even myself to not loose track of what I'm doing. Plus it's easier for the author of the routine to actually summarize what it does.

 

Thank you.

Regards,

[aloy]

This sort of algorithms are taught in secondary school levels in some countries (eg. UK's Cambridge IGSCE syllabus) and is called Decision Maths. I believe it is very useful for computer programmers.

[marko_ribar]

PlPath-t+b.lsp (top + bottom) is part of PLINETOOLS archive, so I am posting link where routine is posted publicly in code tag...

Link :

 

HTH.

Regards; M.R.

[marko_ribar]

Another useful tool, here on this link : https://www.theswamp.org/index.php?topic=59534.0

And another for 3DPOLY(s) : https://www.theswamp.org/index.php?topic=59473.0

 

HTH.

Regards, M.R.

Edited May 8 by marko_ribar

[marko_ribar]

If someone can profit on these, I've updated my "plav.lsp" and "pldv.lsp"...

I hope it proves useful as previous versions had implemented ActiveX VL functions which proved somewhat phallic...

 

(defun c:plav ( / *error* vertlst bulglst wdthlst tang prelst suflst add_vtx osm cmd done pl obj plx pp pt par bl b1 b2 b bb a a1 a2 wl w1 w2 w vl v vv vx vp vpx vn vnx coords sa ans n elev z flag len )

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

  (defun vertlst ( poly / n p pl )
    (if (and poly (not (vlax-erased-p poly)))
      (progn
        (setq n (1+ (fix (+ 0.1 (vlax-curve-getendparam poly)))))
        (while (<= 0 (setq n (1- n)))
          (setq p (vlax-curve-getpointatparam poly (float n)))
          (if
            (and
              (not (equal p (car pl) 1e-6))
              (not (equal p (last pl) 1e-6))
            )
            (setq pl (cons p pl))
          )
        )
      )
    )
    pl
  )

  (defun bulglst ( poly / n b bl )
    (setq n (1+ (fix (+ 0.1 (vlax-curve-getendparam poly)))))
    (while (<= 0 (setq n (1- n)))
      (setq b (vl-catch-all-apply (function vla-getbulge) (list (cond ( (= (type poly) (quote ename)) (vlax-ename->vla-object poly) ) ( (= (type poly) (quote vla-object)) poly )) n)))
      (if (and b (not (vl-catch-all-error-p b)))
        (setq bl (cons b bl))
      )
    )
    bl
  )

  (defun wdthlst ( poly / n w wl w1 w2 )
    (setq n (1+ (fix (+ 0.1 (vlax-curve-getendparam poly)))))
    (while (<= 0 (setq n (1- n)))
      (setq w (vl-catch-all-apply (function vla-getwidth) (list (cond ( (= (type poly) (quote ename)) (vlax-ename->vla-object poly) ) ( (= (type poly) (quote vla-object)) poly )) n (quote w1) (quote w2))))
      (if (and w (not (vl-catch-all-error-p w)))
        (setq wl (cons (list w1 w2) wl))
      )
    )
    wl
  )

  (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 prelst ( 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 suflst ( 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 / substonce getwidthatparam getbulgeatparam obj dxf pref suff wdthlst bulg sw ew n rtn xxx )

    (defun substonce ( a b l / n c )
      (setq n (vl-position b l))
      (mapcar (function (lambda ( x ) (if (not c) (setq c 0) (setq c (1+ c))) (if (= c n) a x))) l)
    )

    (defun getwidthatparam ( ent_name par / dxf sw ew rtn )
      (setq dxf (entget ent_name))
      (while (assoc 40 dxf)
        (setq sw (cdr (assoc 40 dxf)))
        (setq ew (cdr (assoc 41 dxf)))
        (setq rtn (cons (list sw ew) rtn))
        (setq dxf (cdr (member (assoc 41 dxf) dxf)))
      )
      (nth (fix par) (reverse rtn))
    )

    (defun getbulgeatparam ( ent_name par / dxf b rtn )
      (setq dxf (entget ent_name))
      (while (assoc 42 dxf)
        (setq b (cdr (assoc 42 dxf)))
        (setq rtn (cons b rtn))
        (setq dxf (cdr (member (assoc 42 dxf) dxf)))
      )
      (nth (fix par) (reverse rtn))
    )

    (setq obj (vlax-ename->vla-object ent_name))
    (setq dxf (entget ent_name))
    (setq pref (prelst dxf (assoc 39 dxf) nil))
    (setq suff (suflst dxf (assoc 10 dxf) nil))
    (setq wdthlst (getwidthatparam ent_name (fix par)))
    (setq sw (car wdthlst) ew (cadr wdthlst))
    (setq bulg (getbulgeatparam ent_name (fix par)))
    (if (assoc 91 dxf)
      (progn
        (setq n (* 5 (1+ (fix par))))
        (repeat n
          (setq rtn (cons (car suff) rtn))
          (setq suff (cdr suff))
        )
        (setq rtn (substonce (cons 42 (/ (sin (/ (* 4 (atan bulg) (- par (fix par))) 4)) (cos (/ (* 4 (atan bulg) (- par (fix par))) 4)))) (assoc 42 rtn) rtn))
        (setq rtn (substonce (cons 41 (+ sw (* (- ew sw) (- par (fix par))))) (assoc 41 rtn) rtn))
        (setq rtn (substonce (cons 40 sw) (assoc 40 rtn) rtn))
        (setq rtn (cons (list 10 (car (trans (vlax-curve-getpointatparam obj par) 0 ent_name)) (cadr (trans (vlax-curve-getpointatparam obj par) 0 ent_name))) rtn))
        (setq rtn (cons (cons 40 (+ sw (* (- ew sw) (- par (fix par))))) rtn))
        (setq rtn (cons (cons 41 ew) rtn))
        (setq rtn (cons (cons 42 (/ (sin (/ (* 4 (atan bulg) (- (1+ (fix par)) par)) 4)) (cos (/ (* 4 (atan bulg) (- (1+ (fix par)) par)) 4)))) rtn))
        (setq rtn (cons (cons 91 0) rtn))
        (setq xxx (append pref (reverse rtn) suff))
        (setq xxx (subst (cons 90 (1+ (cdr (assoc 90 xxx)))) (assoc 90 xxx) xxx))
      )
      (progn
        (setq n (* 4 (1+ (fix par))))
        (repeat n
          (setq rtn (cons (car suff) rtn))
          (setq suff (cdr suff))
        )
        (setq rtn (substonce (cons 42 (/ (sin (/ (* 4 (atan bulg) (- par (fix par))) 4)) (cos (/ (* 4 (atan bulg) (- par (fix par))) 4)))) (assoc 42 rtn) rtn))
        (setq rtn (substonce (cons 41 (+ sw (* (- ew sw) (- par (fix par))))) (assoc 41 rtn) rtn))
        (setq rtn (substonce (cons 40 sw) (assoc 40 rtn) rtn))
        (setq rtn (cons (list 10 (car (trans (vlax-curve-getpointatparam obj par) 0 ent_name)) (cadr (trans (vlax-curve-getpointatparam obj par) 0 ent_name))) rtn))
        (setq rtn (cons (cons 40 (+ sw (* (- ew sw) (- par (fix par))))) rtn))
        (setq rtn (cons (cons 41 ew) rtn))
        (setq rtn (cons (cons 42 (/ (sin (/ (* 4 (atan bulg) (- (1+ (fix par)) par)) 4)) (cos (/ (* 4 (atan bulg) (- (1+ (fix par)) par)) 4)))) rtn))
        (setq xxx (append pref (reverse rtn) suff))
        (setq xxx (subst (cons 90 (1+ (cdr (assoc 90 xxx)))) (assoc 90 xxx) xxx))
      )
    )
    (entupd (cdr (assoc -1 (entmod xxx))))
  )

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

  (or cad (setq cad (vlax-get-acad-object)))
  (or doc (setq doc (vla-get-activedocument cad)))
  (or spc (setq spc (vla-get-block (setq alo (vla-get-activelayout doc)))))
  (setq osm (getvar (quote osmode)))
  (if (/= 512 (logand 512 osm))
    (setvar (quote osmode) (+ osm 512))
  )
  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (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")
  )
  (while
    (and
      (not done)
      (setq pl (car (entsel "\nSelect pline entity... - ENTER to finish...")))
      (wcmatch (cdr (assoc 0 (setq plx (entget pl)))) "*POLYLINE")
      (or (= (cdr (assoc 70 plx)) 0) (= (cdr (assoc 70 plx)) 1) (= (cdr (assoc 70 plx)) 128) (= (cdr (assoc 70 plx)) 129) (= (cdr (assoc 70 plx)) 8) (= (cdr (assoc 70 plx)) 9))
      (setq obj (vlax-ename->vla-object pl))
    )
    (if command-s
      (command-s "_.UNDO" "_G")
      (vl-cmdf "_.UNDO" "_G")
    )
    (setq len (vlax-curve-getdistatparam pl (vlax-curve-getendparam pl)))
    (if
      (and
        (setq pp (getpoint "\nPick point where you want to add vertex to pline..."))
        (setq pt (trans pp 1 0))
        (setq par (vlax-curve-getparamatpoint pl pt))
      )
      (if (= (cdr (assoc 0 plx)) "LWPOLYLINE")
        (add_vtx pl par)
        (progn
          (setq vl (vertlst pl))
          (setq pt (vlax-curve-getclosestpointto pl pt))
          (setq vl (append (prelst vl nil (fix par)) (list pt) (suflst vl nil (fix (1+ par)))))
          (setq coords (apply (function append) vl))
          (setq sa (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length coords)))))
          (vla-put-coordinates obj (vlax-make-variant (vlax-safearray-fill sa coords)))
          (if (not (equal len (vlax-curve-getdistatparam pl (vlax-curve-getendparam pl)) 1e-6))
            (progn
              (if command-s
                (command-s "_.UNDO" 1)
                (vl-cmdf "_.UNDO" 1)
              )
              (if command-s
                (command-s "_.UNDO" "_G")
                (vl-cmdf "_.UNDO" "_G")
              )
              (if (and (= (cdr (assoc 100 (reverse plx))) "AcDb2dPolyline") (or (= (cdr (assoc 70 plx)) 0) (= (cdr (assoc 70 plx)) 1) (= (cdr (assoc 70 plx)) 128) (= (cdr (assoc 70 plx)) 129)))
                (progn
                  (command "_.CONVERTPOLY" "_L" pl)
                  (while (< 0 (getvar (quote cmdactive)))
                    (command "")
                  )
                  (entupd pl)
                  (add_vtx pl par)
                  (command "_.CONVERTPOLY" "_H" pl)
                  (while (< 0 (getvar (quote cmdactive)))
                    (command "")
                  )
                )
              )
            )
          )
        )
      )
      (prompt "\nMissed picking point on selected polyline...")
    )
    (setq flag nil)
    (while
      (cond
        ( (= ans "eXit")
          (setq done t)
          nil
        )
        ( (= ans "Undo")
          t
        )
        ( (not flag)
          t
        )
        ( flag
          nil
        )
      )
      (initget "Undo eXit")
      (setq ans (getkword "\nType \"Undo\" for restart [Undo / eXit] <ENTER - Continue> : "))
      (cond
        ( (= ans "Undo")
          (if command-s
            (command-s "_.UNDO" 1)
            (vl-cmdf "_.UNDO" 1)
          )
        )
        ( (= ans "eXit")
          (setq flag t)
        )
        ( (not ans)
          (setq flag t)
        )
      )
    )
  )
  (if (and pl (not (and (wcmatch (cdr (assoc 0 plx)) "*POLYLINE") (or (= (cdr (assoc 70 plx)) 0) (= (cdr (assoc 70 plx)) 1) (= (cdr (assoc 70 plx)) 128) (= (cdr (assoc 70 plx)) 129) (= (cdr (assoc 70 plx)) 8) (= (cdr (assoc 70 plx)) 9)))))
    (progn
      (prompt "\nPicked entity isn't valid polyline... Better luck next time...")
      (setq ans "eXit")
    )
    (if (= (getvar (quote errno)) 7)
      (progn
        (prompt "\nMissed... Better luck next time...")
        (setq ans "eXit")
      )
    )
  )
  (prompt "\nFor UNDO - type \"UNDO\" - \"Back\" option...")
  (*error* nil)
)

 

(defun c:pldv ( / *error* substdxfs getwdthlst assocon vertlst bulglst wdthlst tang prelst suflst osm cmd done pl obj plx pp pt par bl b1 b wl w1 w2 vl v vv vx vp vpx coords sa bul ptp parp bulp ptn parn a1 a2 r1 r2 c1 c2 bulpn pll pllp plls plll ans z )

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

  (defun substdxfs ( key dxf lst / n rtn )
    (setq n -1)
    (foreach x dxf
      (if (= (car x) key)
        (setq rtn (cons (cons key (nth (setq n (1+ n)) lst)) rtn))
        (setq rtn (cons x rtn))
      )
    )
    (reverse rtn)
  )

  (defun getwdthlst ( dxf / w1 w2 rtn )
    (while (assoc 40 dxf)
      (setq w1 (cdr (assoc 40 dxf)))
      (setq w2 (cdr (assoc 41 dxf)))
      (setq rtn (cons (list w1 w2) rtn))
      (setq dxf (cdr (member (assoc 41 dxf) dxf)))
    )
    (reverse rtn)
  )

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

  (defun vertlst ( poly / n p pl )
    (if (and poly (not (vlax-erased-p poly)))
      (progn
        (setq n (1+ (fix (+ 0.1 (vlax-curve-getendparam poly)))))
        (while (<= 0 (setq n (1- n)))
          (setq p (vlax-curve-getpointatparam poly (float n)))
          (if
            (and
              (not (equal p (car pl) 1e-6))
              (not (equal p (last pl) 1e-6))
            )
            (setq pl (cons p pl))
          )
        )
      )
    )
    pl
  )

  (defun bulglst ( poly / n b bl )
    (setq n (1+ (fix (+ 0.1 (vlax-curve-getendparam poly)))))
    (while (<= 0 (setq n (1- n)))
      (setq b (vl-catch-all-apply (function vla-getbulge) (list (cond ( (= (type poly) (quote ename)) (vlax-ename->vla-object poly) ) ( (= (type poly) (quote vla-object)) poly )) n)))
      (if (and b (not (vl-catch-all-error-p b)))
        (setq bl (cons b bl))
      )
    )
    bl
  )

  (defun wdthlst ( poly / n w wl w1 w2 )
    (setq n (1+ (fix (+ 0.1 (vlax-curve-getendparam poly)))))
    (while (<= 0 (setq n (1- n)))
      (setq w (vl-catch-all-apply (function vla-getwidth) (list (cond ( (= (type poly) (quote ename)) (vlax-ename->vla-object poly) ) ( (= (type poly) (quote vla-object)) poly )) n (quote w1) (quote w2))))
      (if (and w (not (vl-catch-all-error-p w)))
        (setq wl (cons (list w1 w2) wl))
      )
    )
    wl
  )

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

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

  (or cad (setq cad (vlax-get-acad-object)))
  (or doc (setq doc (vla-get-activedocument cad)))
  (or spc (setq spc (vla-get-block (setq alo (vla-get-activelayout doc)))))
  (setq osm (getvar (quote osmode)))
  (setvar (quote osmode) 1)
  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (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")
  )
  (while
    (and
      (if (= ans "eXit")
        (setq done t)
        (if (setq pl (car (entsel "\nSelect pline entity...")))
          (setq plx (entget pl) obj (vlax-ename->vla-object pl))
          (progn
            (prompt "\nMissed... Better luck next time...")
            (setq done t)
          )
        )
      )
      (not done)
      (if (and pl (not (and (wcmatch (cdr (assoc 0 plx)) "*POLYLINE") (or (= (cdr (assoc 70 plx)) 0) (= (cdr (assoc 70 plx)) 1) (= (cdr (assoc 70 plx)) 128) (= (cdr (assoc 70 plx)) 129) (= (cdr (assoc 70 plx)) 8) (= (cdr (assoc 70 plx)) 9)))))
        (progn
          (prompt "\nPicked entity isn't valid polyline... Better luck next time...")
          (setq done t)
        )
        (not done)
      )
      (not done)
      (not (initget 1))
      (setq pp (getpoint "\nPick vertex you want to remove from pline..."))
      (if (and pl (wcmatch (cdr (assoc 0 plx)) "*POLYLINE") (not (vlax-curve-getparamatpoint pl (trans pp 1 0))))
        (progn
          (prompt "\nMissed picking point on selected polyline...")
          (setq done t)
        )
        (not done)
      )
      (not done)
    )
    (if command-s
      (command-s "_.UNDO" "_G")
      (vl-cmdf "_.UNDO" "_G")
    )
    (if (vlax-curve-getparamatpoint pl (trans pp 1 0))
      (progn
        (setq pt (trans pp 1 0))
        (setq par (vlax-curve-getparamatpoint pl (setq pt (vlax-curve-getclosestpointto pl pt))))
        (setq pt (trans pt 0 pl))
        (if (and (= (cdr (assoc 0 plx)) "LWPOLYLINE") (not (and (equal (vlax-curve-getpointatparam pl par) (vlax-curve-getstartpoint pl) 1e-6) (equal (vlax-curve-getpointatparam pl par) (vlax-curve-getendpoint pl) 1e-6))))
          (progn
            (setq bul (cdr (assoc 42 (vl-member-if (function (lambda ( x ) (equal x (assocon (reverse (cdr (reverse pt))) plx cdr 1e-6) 1e-6))) plx))))
            (cond
              ( (equal (vlax-curve-getpointatparam pl par) (vlax-curve-getstartpoint pl) 1e-6)
                (setq plll (append (reverse (cdr (reverse (prelst plx (assoc 10 plx) nil)))) (if (assoc 91 plx) (cddr (suflst plx (assoc 42 plx) nil)) (cdr (suflst plx (assoc 42 plx) nil)))))
                (setq plll (subst (cons 90 (1- (cdr (assoc 90 plll)))) (assoc 90 plll) plll))
              )
              ( (equal (vlax-curve-getpointatparam pl par) (vlax-curve-getendpoint pl) 1e-6)
                (setq plll (append (reverse (cdr (suflst (reverse plx) (assoc 10 (reverse plx)) nil))) (list (last plx))))
                (setq plll (subst (cons 90 (1- (cdr (assoc 90 plll)))) (assoc 90 plll) plll))
              )
              ( t
                (setq parp (1- par))
                (setq ptp (vlax-curve-getpointatparam pl parp))
                (setq ptp (trans ptp 0 pl))
                (setq bulp (cdr (assoc 42 (vl-member-if (function (lambda ( x ) (equal x (assocon (reverse (cdr (reverse ptp))) plx cdr 1e-6) 1e-6))) plx))))
                (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)
                )
                (setq pll plx)
                (setq pll (append (reverse (cdr (reverse (prelst pll (assocon (reverse (cdr (reverse pt))) pll cdr 1e-6) nil)))) (cdr ((if (assoc 91 pll) cddddr cdddr) (suflst pll (assocon (reverse (cdr (reverse pt))) pll cdr 1e-6) nil)))))
                (setq pllp (reverse (cdr (reverse (prelst pll (assocon (reverse (cdr (reverse ptp))) pll cdr 1e-6) nil)))))
                (setq plls (cdr (suflst pll (assocon (reverse (cdr (reverse ptp))) pll cdr 1e-6) nil)))
                (if (not bulpn)
                  (setq bulpn 0.0)
                )
                (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))
                (setq plll (subst (cons 90 (1- (cdr (assoc 90 plll)))) (assoc 90 plll) plll))
              )
            )
            (if (and (setq bl (bulglst pl)) (>= (1- (fix (+ 0.1 par))) 0))
              (progn
                (setq b1 (vla-getbulge obj (1- (fix (+ 0.1 par)))))
                (setq b (vla-getbulge obj (fix (+ 0.1 par))))
                (setq a1 (* 4.0 (abs (atan b1))))
                (setq a2 (* 4.0 (abs (atan b))))
                (setq b1 (if (minusp b1) (- (abs (tang (/ (+ a1 a2) 4.0)))) (abs (tang (/ (+ a1 a2) 4.0)))))
                (setq bl (append (reverse (cddr (reverse (prelst bl nil (fix (+ 0.1 par)))))) (list b1) (cdr (suflst bl nil (fix (+ 0.1 par))))))
                (setq plll (substdxfs 42 plll bl))
              )
            )
            (if (and (setq wl (getwdthlst plx)) (>= (1- (fix (+ 0.1 par))) 0))
              (progn
                (setq w1 (car (nth (1- (fix (+ 0.1 par))) wl)))
                (setq w2 (cadr (nth (fix (+ 0.1 par)) wl)))
                (setq wl (append (reverse (cddr (reverse (prelst wl nil (fix (+ 0.1 par)))))) (list (list w1 w2)) (cdr (suflst wl nil (fix (+ 0.1 par))))))
                (setq plll (substdxfs 40 plll (mapcar (function car) wl)))
                (setq plll (substdxfs 41 plll (mapcar (function cadr) wl)))
              )
            )
            (if (or bl wl)
              (progn
                (setq z (caddr (safearray-value (variant-value (vla-get-coordinate obj 0)))))
                (setq vl (mapcar (function (lambda ( x ) (append (mapcar (function +) (list 0.0 0.0) (trans x 0 pl)) (list z)))) vl))
                (if (= (cdr (assoc 0 plx)) "LWPOLYLINE")
                  (entupd (cdr (assoc -1 (entmod plll))))
                )
              )
            )
          )
          (if (= (cdr (assoc 0 plx)) "LWPOLYLINE")
            (alert "Picked vertex is start-end vertex of pline and can't be removed...")
          )
        )
        (if (= (cdr (assoc 0 plx)) "POLYLINE")
          (progn
            (setq vl nil v nil vv nil vx nil vp nil vpx nil) 
            (if (or (= (cdr (assoc 70 plx)) 8) (= (cdr (assoc 70 plx)) 9))
              (progn
                (setq vl (vertlst pl))
                (setq vl (vl-remove-if (function (lambda ( x ) (equal x pt 1e-6))) vl))
                (setq coords (apply (function append) vl))
                (setq sa (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length coords)))))
                (vla-put-coordinates obj (vlax-make-variant (vlax-safearray-fill sa coords)))
              )
              (progn
                (if (and (setq bl (bulglst pl)) (>= (1- (fix (+ 0.1 par))) 0))
                  (progn
                    (setq b1 (vla-getbulge obj (1- (fix (+ 0.1 par)))))
                    (setq b (vla-getbulge obj (fix (+ 0.1 par))))
                    (setq a1 (* 4.0 (abs (atan b1))))
                    (setq a2 (* 4.0 (abs (atan b))))
                    (setq b1 (if (minusp b1) (- (abs (tang (/ (+ a1 a2) 4.0)))) (abs (tang (/ (+ a1 a2) 4.0)))))
                  )
                )
                (setq v (entnext pl))
                (setq vv (cons v vv))
                (while (setq v (entnext v))
                  (setq vv (cons v vv))
                )
                (if (/= (cdr (assoc 0 (entget (car vv)))) "VERTEX")
                  (setq vv (cdr vv))
                )
                (setq vv (reverse vv))
                (if (>= (1- (fix (+ 0.1 par))) 0)
                  (setq vp (nth (1- (fix (+ 0.1 par))) vv))
                  (setq vp (nth (fix (+ 0.1 par)) vv))
                )
                (setq vpx (entget vp))
                (if b1
                  (setq vpx (substdxfs 42 vpx (list b1)))
                  (setq vpx (substdxfs 42 vpx (list 0.0)))
                )
                (setq w1 (getwdthlst vpx))
                (if (nth (1+ (fix (+ 0.1 par))) vv)
                  (setq w2 (getwdthlst (entget (nth (1+ (fix (+ 0.1 par))) vv))))
                  (setq w2 (list (list 0.0 0.0)))
                )
                (setq vpx (substdxfs 40 vpx (list (caar w1))))
                (setq vpx (substdxfs 41 vpx (list (caar w2))))
                (if (not (equal vpx (entget vp) 1e-6))
                  (entupd (cdr (assoc -1 (entmod vpx))))
                )
                (vla-delete (vlax-ename->vla-object (nth (fix (+ 0.1 par)) vv)))
              )
            )
            (vla-update obj)
          )
        )
      )
    )
    (initget "Undo eXit")
    (setq ans (getkword "\nType \"Undo\" for restart [Undo / eXit] <ENTER - Continue> : "))
    (while
      (cond
        ( (= ans "eXit")
          (setq done t)
          nil
        )
        ( (= ans "Undo")
          (if command-s
            (command-s "_.UNDO" 1)
            (vl-cmdf "_.UNDO" 1)
          )
          (setq done nil)
        )
        ( (not ans)
          (setq done nil)
        )
      )
    )
  )
  (prompt "\nFor UNDO - type \"UNDO\" - \"Back\" option...")
  (*error* nil)
)

 

Regards, M.R.

Edited September 25 by marko_ribar