Divide polyline at equal intervals AND at vertices

[rouho]

Hello,

 

I am looking for a lisp that would add a point along a polyline at given intervals (e.g. 50m) AND at each vertex ONLY if the distance between the two adjacent vertices is greater than the selected segment interval.

 

Thank you.

[Tharwat]

Try this ...

 

(defun c:Test (/ _Pt ss in d)
 ;; Tharwat 11.11.2013 ;;
 (defun _Pt (pt) (entmakex (list '(0 . "POINT") (cons 10 pt))))
 (if (and (setq ss (ssget '((0 . "LWPOLYLINE"))))
          (setq in (getdist "\n Specify the Interval :"))
          (setq d in)
     )
   ((lambda (i / sn p)
      (while (setq sn (ssname ss (setq i (1+ i))))
        (while (setq p (vlax-curve-getpointatdist sn d)) (_Pt p) (setq d (+ d in)))
        (mapcar '_Pt (mapcar 'cdr (vl-remove-if-not '(lambda (u) (eq (car u) 10)) (entget sn))))
        (setq d in)
      )
    )
     -1
   )
 )
 (princ)
)
(vl-load-com)

[rouho]

Tharwat thank you.

Is it possible that the point between two vertices is added only if the distance between two vertices is greater than the selected segment interval? What I mean is that if two vertices are 20m apart and the segment interval is 25m then between these two vertices should be no point no matter where the division from the beginning falls.

 

I would like to avoid having two point (vertex and another one) too close.

 

Thanks

[Tharwat]

As I can tell you that you want to compare the interval length according to each every two vertices after each other and to add points at every interval , is this correct ?

[rouho]

Yes that's correct.

 

Thanks

[Tharwat]

Yes that's correct.

 

Thanks

 

Just to save time and to do the routine in one shut , I hope you do not mind to upload a sample drawing showing your statement clearly with an example

[rouho]

here is a sample file.

thank you.

Drawing.dwg

[marko_ribar]

rouho, please look in attached DWG... Wouldn't this division be nicer?

 

M.R.

Drawing.dwg

[rouho]

Indeed, this is great!

[marko_ribar]

Then here is my version :

 

(defun c:divplsegs (/ ss mind i pl ep k j dk dj d n dd m p)
 (vl-load-com)
 (prompt "\nSelect 2d polylines...")
 (setq ss (ssget '((0 . "*POLYLINE") (-4 . "<not") (-4 . "&=") (70 .  (-4 . "not>"))))
 (initget 7)
 (setq mind (getdist "\nSpecify min. distance for segments division: "))
 (setq i -1)
 (while (setq pl (ssname ss (setq i (1+ i))))
   (setq ep (vlax-curve-getendparam pl))
   (setq k -1.0)
   (while (< (setq k (1+ k)) ep)
     (setq j (1+ k))
     (setq dk (vlax-curve-getdistatparam pl k))
     (setq dj (vlax-curve-getdistatparam pl j))
     (setq d (- dj dk))
     (setq n (fix (/ d mind)))
     (if (> n 1)
       (progn
         (setq dd (/ d (float n)))
         (setq m -1.0)
         (repeat n
           (setq p (vlax-curve-getpointatdist pl (+ dk (* dd (setq m (1+ m))))))
           (entmake (list '(0 . "POINT") (cons 10 p)))
         )
       )
       (progn
         (setq p (vlax-curve-getpointatdist pl dk))
         (entmake (list '(0 . "POINT") (cons 10 p)))
       )
     )
   )
   (entmake (list '(0 . "POINT") (cons 10 (vlax-curve-getendpoint pl))))
 )
 (princ)
)

 

Regards, M.R.

[rouho]

M.R. the last lisp works great

 

 

Thank you so much both of you guys !

[rouho]

Hello Marko,

 

is it possible to customize your lisp so as to add a point and a vertex on the new segments. What I mean is to have a polyline vertex under each inserted point.

 

Thank you

[marko_ribar]

(defun c:divplsegs+vtxs ( / add_vtx trunc clean_poly ss ssh mind i pl ep k j dk dj d n dd m p ptlst )

 (vl-load-com)

 (defun add_vtx ( obj add_pt ent_name / bulg )
     (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-update obj)
 )

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

 (defun clean_poly ( ent / e_lst p_lst vtx1 vtx2 )
   (setq e_lst (entget ent))
   (cond
     ((= "LWPOLYLINE" (cdr (assoc 0 e_lst)))
      (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 (cdr (assoc 70 e_lst)))
        (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)
     )
     ((and (= "POLYLINE" (cdr (assoc 0 e_lst)))
     (zerop (logand 240 (cdr (assoc 70 e_lst))))
      )
      (setq e_lst (cons e_lst nil)
      vtx1     (entnext ent)
      vtx2     (entnext vtx1)
      )
      (while (= (cdr (assoc 0 (entget vtx1))) "VERTEX")
        (if (= (cdr (assoc 0 (entget vtx2))) "SEQEND")
    (if
      (or (not
      (equal    (assoc 10 (entget vtx1))
       (assoc 10 (last (reverse (cdr (reverse e_lst)))))
      )
          )
          (zerop (logand 1 (cdr (assoc 70 (last e_lst)))))
      )
       (setq e_lst (cons (entget vtx1) e_lst))
    )
    (if
      (not
        (equal (assoc 10 (entget vtx1)) (assoc 10 (entget vtx2)) 1e-9)
      )
       (setq e_lst (cons (entget vtx1) e_lst))
    )
        )
        (setq vtx1 vtx2
        vtx2 (entnext vtx1)
        )
      )
      (setq e_lst (reverse (cons (entget vtx1) e_lst)))
      (entdel ent)
      (mapcar 'entmake e_lst)
     )
     (T (princ "\nEntité non valide."))
   )
   (princ)
 )

 (prompt "\nSelect 2d polylines...")
 (setq ss (ssget "_:L" '((0 . "*POLYLINE") (-4 . "<not") (-4 . "&=") (70 .  (-4 . "not>"))))
 (setq ssh (ssadd))
 (initget 7)
 (setq mind (getdist "\nSpecify min. distance for segments division: "))
 (setq i -1)
 (while (setq pl (ssname ss (setq i (1+ i))))
   (if (eq (cdr (assoc 0 (entget pl))) "POLYLINE")
     (progn
       (command "_.convertpoly" "_l" pl "")
       (ssadd pl ssh)
     )
   )
   (setq ep (vlax-curve-getendparam pl))
   (setq k -1.0)
   (while (< (setq k (1+ k)) ep)
     (setq j (1+ k))
     (setq dk (vlax-curve-getdistatparam pl k))
     (setq dj (vlax-curve-getdistatparam pl j))
     (setq d (- dj dk))
     (setq n (fix (/ d mind)))
     (if (> n 1)
       (progn
         (setq dd (/ d (float n)))
         (setq m -1.0)
         (repeat n
           (setq p (vlax-curve-getpointatdist pl (+ dk (* dd (setq m (1+ m))))))
           (entmake (list '(0 . "POINT") (cons 10 p)))
           (setq ptlst (cons p ptlst))
         )
       )
       (progn
         (setq p (vlax-curve-getpointatdist pl dk))
         (entmake (list '(0 . "POINT") (cons 10 p)))
         (setq ptlst (cons p ptlst))
       )
     )
   )
   (entmake (list '(0 . "POINT") (cons 10 (vlax-curve-getendpoint pl))))
   (setq ptlst (cons p ptlst))
   (foreach p (reverse ptlst)
     (vl-catch-all-apply 'add_vtx (list (vlax-ename->vla-object pl) (vlax-curve-getparamatpoint pl (vlax-curve-getclosestpointto pl p)) pl))
   )
   (setq ptlst nil)
   (clean_poly pl)
 )
 (setq i -1)
 (while (setq pl (ssname ssh (setq i (1+ i))))
   (command "_.convertpoly" "_h" pl "")
 )
 (princ)
)

M.R.

Edited January 8, 2014 by marko_ribar