Trace specify length on pipe network

[reza]

Hi all

I want to show a specific length from specify point (for example: 1350 meter) on the network of main and secondary pipe lines.

Of course, I raised this problem in the map 3d forum so that maybe it can be solved by creating a topology.
But it seems that this is not possible in map 3d (network topology).

The point specified by the user can be at the beginning of one pipe(polyline) and at the end of another pipe(polyline) at the same time (green polyline and red polyline).

But surely the point selected by the user will not be somewhere else on the polyline.

I want to specify the start point ,then program to select the polylines that are in contact with it and to show a point on the main pipes and branches.

and all the main pipes' Polylines and all sub pipes' polylines no contain arc segments.

If creating a vertex on the main pipe at the intersection of the secondary pipe helps to solve the problem, I can do this.

I will be very grateful if you can guide me in solving this problem.

Please help me by Lisp if possible.

1NET.dwg

[mhupp]

See if this helps.

http://www.lee-mac.com/totallengthpline.html

[BIGAL]

It is very easy to find a p/line touching another P/Line when you use ssget "F" it detects any other lines touching the selected main line. You can then look at start/end point of the touching line and get the distance along the main line.

 

Before I do something I can see this 6" pot tree growing to a 100' monster tree, post a real dwg. I can just see SUB SUB SUB.

 

 

For me I have drainage & sewer software so it does what you want but its commercial software it could be used for water mains as well as pipe sizes are taken into account.

 

Civil Site Design • Civil Survey Solutions for Civil 3D & BricsCAD

 

 

Edited August 23, 2022 by BIGAL

[reza]

thx dear bigal

It is not a problem to find the intersection.
The problem is to specify the desired length on the main and secondary polylines.

IDEA Network Topology.dwg

[BIGAL]

Still confused, so you want to enter 50 and get a point on your main 50 away from start point, and the same distance but along main and then ending somewhere along sub at total of 50.

 

Edited August 24, 2022 by BIGAL

[reza]

Dear Bigal thank you for reply

You got it exactly right.

I want the desired length to be determined from the start point specified by the user in the main and secondary routes.

The red polylines are the main routes and the blue polylines are the secondary routes.

[marko_ribar]

Try this snippet for a start... If something's wrong, reply...

 

(defun c:pts_along_pipe_trees_by_length ( / process pt dd s i d )

  (vl-load-com)

  (defun process ( / el )
    (setq s (ssget "_C" (setq pt (osnap pt "_nea")) pt))
    (repeat (setq i (sslength s))
      (setq el (cons (ssname s (setq i (1- i))) el))
    )
    (if (vl-some (function (lambda ( x ) (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-curve-getstartpoint) (list x)))))) el)
      (foreach e el
        (setq d (vlax-curve-getdistatpoint e (trans pt 1 0)))
        (cond
          ( (> (+ d dd) (setq len (vlax-curve-getdistatparam e (vlax-curve-getendparam e))))
            (setq dd (- dd (- len d)))
            (setq pt (vlax-curve-getendpoint e))
            (process)
          )
          ( (< (- d dd) 0.0)
            (setq dd (- dd (- len d)))
            (setq pt (vlax-curve-getstartpoint e))
            (process)
          )
          ( t
            (if (zerop d)
              (entmake (list (cons 0 "POINT") (cons 10 (vlax-curve-getpointatdist e dd))))
              (entmake (list (cons 0 "POINT") (cons 10 (vlax-curve-getpointatdist e (- (vlax-curve-getdistatparam e (vlax-curve-getendparam e)) dd)))))
            )
          )
        )
      )
    )
  )

  (if
    (and
      (setq pt (getpoint "\nPick or specify main base point : "))
      (not (initget 6))
      (setq dd (cond ( (not (setq dd (getdist pt "\nPick or specify length from base point for spread around <1.0> : "))) 1.0 ) ( t dd )))
    )
    (process)
  )
  (princ)
)

 

Regards, M.R.

HTH.

[reza]

Hi dear Marko

Thank you for your attention, I hope I can use your help as always.

I used your code, but this is not work in my attached file:

 

Pick or specify main base point : end,int of
Pick or specify length from base point for spread around <1.0> : 1350
Hard error occurred ***
internal stack limit reached (simulated)

----------------------------------------------------------------

Pick or specify main base point : end,int of
Pick or specify length from base point for spread around <1.0> : 1350
; error: bad DXF group: (10)

----------------------------------------------------------------

Is it possible to find the desired length in the branches in your code?

 

[reza]

Hi dear Marko

Thank you for your attention, I hope I can use your help as always.

I used your code, but this is not work in my attached file:

 

Pick or specify main base point : end,int of
Pick or specify length from base point for spread around <1.0> : 1350
Hard error occurred ***
internal stack limit reached (simulated)

----------------------------------------------------------------

Pick or specify main base point : end,int of
Pick or specify length from base point for spread around <1.0> : 1350
; error: bad DXF group: (10)

----------------------------------------------------------------

Is it possible to find the desired length in the branches in your code?

[reza]

Sorry, it was replayed again.

[marko_ribar]

I've changed it a little, but it seems that it don't want to go through all branches... No time now, maybe later...

 

(defun c:pts_along_pipe_trees_by_length ( / process pt dd ell )

  (vl-load-com)

  (defun process ( dd pt / proclst processlst s i el e pt d len f n par l )

    (defun proclst ( f len dd pt / par ddd )
      (if
        (and
          (setq par (float (fix (vlax-curve-getparamatpoint e (trans pt 1 0)))))
          (setq pt (vlax-curve-getpointatparam e par))
        )
        (if f
          (progn
            (setq ddd (- dd (- len (vlax-curve-getdistatpoint e (trans (setq pt (trans pt 0 1)) 1 0)))))
            (setq processlst (cons (list ddd pt) processlst))
          )
          (progn
            (setq ddd (- dd (vlax-curve-getdistatpoint e (trans (setq pt (trans pt 0 1)) 1 0))))
            (setq processlst (cons (list ddd pt) processlst))
          )
        )
      )
    )

    (setq s (ssget "_C" (setq pt (osnap pt "_nea")) pt (list (cons 0 "*POLYLINE"))))
    (repeat (setq i (sslength s))
      (if
        (and
          (not (vl-position (setq e (ssname s (setq i (1- i)))) ell))
          (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-curve-getstartpoint) (list e))))
        )
        (setq el (cons (list e pt) el))
      )
    )
    (setq ell (append (mapcar (function car) el) ell))
    (foreach ep el
      (setq f nil l nil)
      (setq e (car ep) pt (cadr ep))
      (setq d (vlax-curve-getdistatpoint e (trans pt 1 0)))
      (setq len (vlax-curve-getdistatparam e (vlax-curve-getendparam e)))
      (if (equal d len 1e-6)
        (setq d 0.0 f t)
      )
      (setq n (fix (setq par (vlax-curve-getparamatpoint e (trans pt 1 0)))))
      (if f
        (foreach p (reverse (repeat n (setq l (cons (trans (vlax-curve-getpointatparam e (float (1+ (fix (setq par (1- par)))))) 0 1) l))))
          (proclst f len dd p)
        )
        (foreach p (reverse (repeat (- (fix (+ 0.1 (vlax-curve-getendparam e))) n) (setq l (cons (trans (vlax-curve-getpointatparam e (float (1- (fix (setq par (1+ par)))))) 0 1) l))))
          (proclst f len dd p)
        )
      )
      (cond
        ( (and
            (zerop d)
            (= (cdr (assoc 90 (entget e))) 2)
            (if f
              (vlax-curve-getpointatdist e (- len dd))
              (vlax-curve-getpointatdist e dd)
            )
          )
          (if f
            (entmake (list (cons 0 "POINT") (cons 10 (vlax-curve-getpointatdist e (- len dd)))))
            (entmake (list (cons 0 "POINT") (cons 10 (vlax-curve-getpointatdist e dd))))
          )
        )
        ( (<= 0.0 (+ d dd) len)
          (if f
            (entmake (list (cons 0 "POINT") (cons 10 (vlax-curve-getpointatdist e (- len (+ d dd))))))
            (entmake (list (cons 0 "POINT") (cons 10 (vlax-curve-getpointatdist e (+ d dd)))))
          )
        )
      )
    )
    (foreach lst processlst
      (process (car lst) (cadr lst))
    )
  )

  (if
    (and
      (setq pt (getpoint "\nPick or specify main base point : "))
      (not (initget 6))
      (setq dd (cond ( (not (setq dd (getdist pt "\nPick or specify length from base point for spread around <1.0> : "))) 1.0 ) ( t dd )))
    )
    (progn
      (vla-zoomextents (vlax-get-acad-object))
      (process dd pt)
    )
  )
  (princ)
)

 

Regards, M.R.

HTH.

Edited August 24, 2022 by marko_ribar

[reza]

THX dear marko

That's great, This is exactly what I wanted.

As you said, it does not apply to all branches.
The code works only if the branch is on the first vertex of the main polyline.

I would be grateful if you could complete it (maybe later).

I really appreciate your attention.

 

Edited August 24, 2022 by reza

[marko_ribar]

I think I've corrected at least according to my testings...

Bye...

[reza]

Thank you again dear Marko for taking the time to solve my problem.

I look forward to your solution to this problem.

[marko_ribar]

I've improved it just a little in a fashion that now there is an option for overdrawing branches... But still they are not complete in overall lengths - for now that's all... If you can alter it to become like in your examples, then it would be perfect... I am over with this now...

 

(defun c:pts_along_pipe_trees_by_length ( / *error* process cad doc pt bp dd ch c ell )

  (vl-load-com)

  (defun *error* ( m )
    (if
      (and
        doc
        (= 8 (logand 8 (getvar 'undoctl)))
      )
      (vla-endundomark doc)
    )
    (if doc
      (vla-regen doc acactiveviewport)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun process ( dd pt / proclst makepoly processlst s i el e pt d len f n par l p )

    (defun proclst ( f len dd pt / par ddd )
      (if
        (and
          (setq par (float (fix (vlax-curve-getparamatpoint e (trans pt 1 0)))))
          (setq pt (vlax-curve-getpointatparam e par))
        )
        (if f
          (progn
            (setq ddd (- dd (- len (vlax-curve-getdistatpoint e (trans (setq pt (trans pt 0 1)) 1 0)))))
            (setq processlst (cons (list ddd pt) processlst))
          )
          (progn
            (setq ddd (- dd (vlax-curve-getdistatpoint e (trans (setq pt (trans pt 0 1)) 1 0))))
            (setq processlst (cons (list ddd pt) processlst))
          )
        )
      )
    )

    (defun makepoly ( f e p c / ln ep i pbl par b ll lx a ex )
      (setq ln (vlax-curve-getdistatparam e (setq ep (vlax-curve-getendparam e))))
      (repeat (setq i (1+ (fix (+ 0.1 ep))))
        (setq pbl (cons (list (vlax-curve-getpointatparam e (float (setq i (1- i)))) (if (not (vl-catch-all-error-p (setq b (vl-catch-all-apply (function vla-getbulge) (list (vlax-ename->vla-object e) i))))) b)) pbl))
      )
      (setq par (vlax-curve-getparamatpoint e (vlax-curve-getclosestpointto e p)))
      (if (equal par ep 1e-6)
        (setq f t)
      )
      (if f
        (progn
          (setq par (- ep par))
          (setq pbl (mapcar (function (lambda ( x ) (list (car x) (if (cadr x) (- (cadr x)))))) (reverse pbl)))
        )
      )
      (if (setq b (cadr (nth (fix (+ par 1.000001)) pbl)))
        (progn
          (setq ll (if f (- (- ln (vlax-curve-getdistatparam e (float (fix par)))) (- ln (vlax-curve-getdistatparam e (float (fix (+ par 1.000001)))))) (- (vlax-curve-getdistatparam e (float (fix (+ par 1.000001)))) (vlax-curve-getdistatparam e (float (fix par))))))
          (setq lx (if f (- (- ln (vlax-curve-getdistatparam e (float (fix par)))) (- ln (vlax-curve-getdistatparam e par))) (- (vlax-curve-getdistatparam e par) (vlax-curve-getdistatparam e (float (fix par))))))
          (setq a (* 4.0 (atan b)))
          (setq b (/ (sin (/ (* (/ a ll) lx) 4.0)) (cos (/ (* (/ a ll) lx) 4.0))))
        )
      )
      (setq pbl (reverse (member (nth (fix par) pbl) (reverse pbl))))
      (setq pbl (append (subst (list (car (last pbl)) b) (last pbl) pbl) (list (list p nil))))
      (setq ex (entget e))
      (if (vl-some (function numberp) (mapcar (function cadr) pbl))
        (entmake
          (append
            (list
              (cons 0 "LWPOLYLINE")
              (cons 100 "AcDbEntity")
              (cons 100 "AcDbPolyline")
              (cons 90 (length pbl))
              (cons 70 (* 128 (getvar 'plinegen)))
              (assoc 38 ex)
            )
            (apply (function append) (mapcar (function (lambda ( x ) (list (cons 10 (trans (car x) 0 (cdr (assoc 210 ex)))) (cons 42 (if (cadr x) (cadr x) 0.0))))) pbl))
            (list
              (assoc 210 ex)
              (cons 62 c)
            )
          )
        )
        (progn
          (vl-cmdf "_.3DPOLY")
          (foreach pb pbl
            (vl-cmdf "_non" (trans (car pb) 0 1))
          )
          (vl-cmdf "")
          (entupd (cdr (assoc -1 (entmod (if (assoc 62 (setq ex (entget (entlast)))) (subst (cons 62 c) (assoc 62 ex) ex) (append ex (list (cons 62 c))))))))
        )
      )
    )

    (setq s (ssget "_C" (setq pt (osnap pt "_nea")) pt (list (cons 0 "*POLYLINE"))))
    (repeat (setq i (sslength s))
      (if
        (and
          (not (vl-position (setq e (ssname s (setq i (1- i)))) ell))
          (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-curve-getstartpoint) (list e))))
        )
        (setq el (cons (list e pt) el))
      )
    )
    (setq ell (append (mapcar (function car) el) ell))
    (foreach ep el
      (setq f nil l nil)
      (setq e (car ep) pt (cadr ep))
      (setq d (vlax-curve-getdistatpoint e (trans pt 1 0)))
      (setq len (vlax-curve-getdistatparam e (vlax-curve-getendparam e)))
      (if (equal d len 1e-6)
        (setq d 0.0 f t)
      )
      (setq n (fix (setq par (vlax-curve-getparamatpoint e (trans pt 1 0)))))
      (if f
        (foreach p (reverse (repeat n (setq l (cons (trans (vlax-curve-getpointatparam e (float (1+ (fix (setq par (1- par)))))) 0 1) l))))
          (proclst f len dd p)
        )
        (foreach p (reverse (repeat (- (fix (+ 0.1 (vlax-curve-getendparam e))) n) (setq l (cons (trans (vlax-curve-getpointatparam e (float (1- (fix (setq par (1+ par)))))) 0 1) l))))
          (proclst f len dd p)
        )
      )
      (cond
        ( (and
            (zerop d)
            (= (cdr (assoc 90 (entget e))) 2)
            (if f
              (vlax-curve-getpointatdist e (- len dd))
              (vlax-curve-getpointatdist e dd)
            )
          )
          (if f
            (progn
              (entmake (list (cons 0 "POINT") (cons 10 (setq p (vlax-curve-getpointatdist e (- len dd))))))
              (if (= ch "Yes") (makepoly f e p c))
            )
            (progn
              (entmake (list (cons 0 "POINT") (cons 10 (setq p (vlax-curve-getpointatdist e dd)))))
              (if (= ch "Yes") (makepoly f e p c))
            )
          )
        )
        ( (<= 0.0 (+ d dd) len)
          (if f
            (progn
              (entmake (list (cons 0 "POINT") (cons 10 (setq p (vlax-curve-getpointatdist e (- len (+ d dd)))))))
              (if (= ch "Yes") (makepoly f e p c))
            )
            (progn
              (entmake (list (cons 0 "POINT") (cons 10 (setq p (vlax-curve-getpointatdist e (+ d dd))))))
              (if (= ch "Yes") (makepoly f e p c))
            )
          )
        )
      )
    )
    (foreach lst processlst
      (process (car lst) (cadr lst))
    )
  )

  (if
    (and
      (setq doc (vla-get-activedocument (setq cad (vlax-get-acad-object))))
      (= 8 (logand 8 (getvar 'undoctl)))
    )
    (vla-endundomark doc)
  )
  (if doc
    (vla-startundomark doc)
  )
  (if
    (and
      (setq pt (getpoint "\nPick or specify main base point : "))
      (setq bp pt)
      (not (initget 6))
      (setq dd (cond ( (not (setq dd (getdist pt "\nPick or specify length from base point for spread around <1.0> : "))) 1.0 ) ( t dd )))
      (not (initget "Yes No"))
      (setq ch (cond ( (not (setq ch (getkword "\nDo you want to overmake new polylines up to resulting points [Yes / No] <Yes> : "))) "Yes" ) ( t ch )))
      (if (= ch "Yes")
        (progn
          (initget 6)
          (setq c (cond ( (not (setq c (getint "\nSpecify color for new polylines <3> : "))) 3 ) ( t c )))
        )
        t
      )
    )
    (progn
      (vla-zoomextents (vlax-get-acad-object))
      (process dd pt)
    )
  )
  (princ)
)

 

Regards, M.R.

Edited August 26, 2022 by marko_ribar

[reza]

Dear marko_ribar:
You are amazing.
You are great.

My problem was solved in the best way by you.
You are one of the best programmers I know in AutoCAD.
What you did to solve this problem was really great.
I wish you the best.

Edited August 24, 2022 by reza

[marko_ribar]

Here is final version... It should work as desired like you wanted...

Regards, M.R.

 

(defun c:pts_along_pipe_trees_by_length-new ( / preprocess process pt bp dd ch c ell xll pxx ) ; ell xll pxx - lexical globals

  (vl-load-com)

  (defun preprocess ( / ss ex i b vbl sa coords )
    (if (setq ss (ssget "_A" (list (cons 0 "*POLYLINE"))))
      (foreach pl (vl-remove (function listp) (mapcar (function cadr) (ssnamex ss)))
        (if
          (or
            (= (cdr (assoc 90 (setq ex (entget pl)))) 1)
            (and
              (= (cdr (assoc 90 ex)) 2)
              (equal (cdr (assoc 10 ex)) (cdr (assoc 10 (reverse ex))) 1e-6)
            )
          )
          (entdel pl)
        )
        (if (not (vlax-erased-p pl))
          (progn
            (setq vbl nil)
            (setq i (1+ (fix (+ 0.1 (vlax-curve-getendparam pl)))))
            (while (<= 0 (setq i (1- i)))
              (setq vbl (cons (list (vlax-curve-getpointatparam pl (float i)) (if (not (vl-catch-all-error-p (setq b (vl-catch-all-apply (function vla-getbulge) (list (vlax-ename->vla-object pl) i))))) b)) vbl))
            )
            (setq vbl (vl-remove-if-not (function (lambda ( x ) (= (length (vl-remove-if (function (lambda ( y ) (equal (car x) y 1e-6))) (mapcar (function car) vbl))) (1- (length vbl))))) vbl))
            (if (not (vl-position (cons 100 "AcDb3dPolyline") ex))
              (progn
                (setq vbl (mapcar (function (lambda ( x ) (list (trans (car x) 0 (cdr (assoc 210 ex))) (cadr x)))) vbl))
                (setq ex (subst (cons 90 (length vbl)) (assoc 90 ex) ex))
                (setq ex (append (vl-remove-if (function (lambda ( x ) (vl-position (car x) (list 10 40 41 42 91 210)))) ex) (apply (function append) (mapcar (function (lambda ( x ) (list (cons 10 (car x)) (cons 40 0.0) (cons 41 0.0) (cons 42 (cadr x)) (cons 91 0.0)))) vbl)) (list (assoc 210 ex))))
                (entupd (cdr (assoc -1 (entmod ex))))
              )
              (progn
                (setq sa (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length (setq coords (apply (function append) (mapcar (function car) vbl))))))))
                (vla-put-coordinates (vlax-ename->vla-object pl) (vlax-make-variant (vlax-safearray-fill sa coords)))
              )
            )
          )
        )
      )
    )
  )  

  (defun process ( dd pt / proclst makepoly processlst ss sss i el e pt d len f n par l p )

    (defun proclst ( f len dd pt / par ddd )
      (if
        (and
          (setq par (float (fix (vlax-curve-getparamatpoint e (trans pt 1 0)))))
          (setq pt (vlax-curve-getpointatparam e par))
        )
        (if f
          (progn
            (setq ddd (- dd (- len (vlax-curve-getdistatpoint e (trans (setq pt (trans pt 0 1)) 1 0)))))
            (setq processlst (cons (list ddd pt) processlst))
          )
          (progn
            (setq ddd (- dd (vlax-curve-getdistatpoint e (trans (setq pt (trans pt 0 1)) 1 0))))
            (setq processlst (cons (list ddd pt) processlst))
          )
        )
      )
    )

    (defun makepoly ( f e p c / polyprocess s ee pl1 pl2 vl i )

      (defun polyprocess ( f e p c / ln ep i pbl par b ll lx a ex )
        (setq ln (vlax-curve-getdistatparam e (setq ep (vlax-curve-getendparam e))))
        (repeat (setq i (1+ (fix (+ 0.1 ep))))
          (setq pbl (cons (list (vlax-curve-getpointatparam e (float (setq i (1- i)))) (if (not (vl-catch-all-error-p (setq b (vl-catch-all-apply (function vla-getbulge) (list (vlax-ename->vla-object e) i))))) b)) pbl))
        )
        (setq par (vlax-curve-getparamatpoint e (vlax-curve-getclosestpointto e p)))
        (if (equal par ep 1e-6)
          (setq f t)
        )
        (if f
          (progn
            (setq par (- ep par))
            (setq pbl (mapcar (function (lambda ( x ) (list (car x) (if (cadr x) (- (cadr x)))))) (reverse pbl)))
          )
        )
        (if (setq b (cadr (nth (fix (+ par 1.000001)) pbl)))
          (progn
            (setq ll (if f (- (- ln (vlax-curve-getdistatparam e (float (fix par)))) (- ln (vlax-curve-getdistatparam e (float (fix (+ par 1.000001)))))) (- (vlax-curve-getdistatparam e (float (fix (+ par 1.000001)))) (vlax-curve-getdistatparam e (float (fix par))))))
            (setq lx (if f (- (- ln (vlax-curve-getdistatparam e (float (fix par)))) (- ln (vlax-curve-getdistatparam e par))) (- (vlax-curve-getdistatparam e par) (vlax-curve-getdistatparam e (float (fix par))))))
            (setq a (* 4.0 (atan b)))
            (setq b (/ (sin (/ (* (/ a ll) lx) 4.0)) (cos (/ (* (/ a ll) lx) 4.0))))
          )
        )
        (setq pbl (reverse (member (nth (fix par) pbl) (reverse pbl))))
        (setq pbl (append pbl (list (list p b))))
        (setq ex (entget e))
        (if (vl-some (function numberp) (mapcar (function cadr) pbl))
          (entmakex
            (append
              (list
                (cons 0 "LWPOLYLINE")
                (cons 100 "AcDbEntity")
                (cons 100 "AcDbPolyline")
                (cons 90 (length pbl))
                (cons 70 (* 128 (getvar 'plinegen)))
                (assoc 38 ex)
              )
              (apply (function append) (mapcar (function (lambda ( x ) (list (cons 10 (trans (car x) 0 (cdr (assoc 210 ex)))) (cons 42 (if (cadr x) (cadr x) 0.0))))) pbl))
              (list
                (assoc 210 ex)
                (cons 62 c)
              )
            )
          )
          (progn
            (vl-cmdf "_.3DPOLY")
            (foreach pb pbl
              (vl-cmdf "_non" (trans (car pb) 0 1))
            )
            (vl-cmdf "")
            (entupd (cdr (assoc -1 (entmod (if (assoc 62 (setq ex (entget (entlast)))) (subst (cons 62 c) (assoc 62 ex) ex) (append ex (list (cons 62 c))))))))
          )
        )
      )

      (setq xll (cons (setq pl1 (polyprocess f e p c)) xll))
      (setq pxx
        (cons
          (progn
            (setq vl nil)
            (setq i (1+ (fix (+ 0.1 (vlax-curve-getendparam pl1)))))
            (while (<= 0 (setq i (1- i)))
              (setq vl (cons (vlax-curve-getpointatparam pl1 (float i)) vl))
            )
          )
          pxx
        )
      )
      (if
        (and
          (not (equal (setq p (vlax-curve-getpointatparam pl1 0.0)) (trans bp 1 0) 1e-6))
          (setq s (ssget "_C" (trans p 0 1) (trans p 0 1) (list (cons 0 "*POLYLINE"))))
          (> (sslength s) 1)
        )
        (progn
          (gc)
          (if (ssmemb pl1 s)
            (ssdel pl1 s)
          )
          (foreach x ell
            (if (and s (ssmemb x s))
              (ssdel x s)
            )
          )
          (if (and s (> (sslength s) 0))
            (setq ee (ssname s 0))
          )
        )
      )
      (if ee
        (progn
          (if (< (vlax-curve-getparamatpoint ee (trans bp 1 0)) (vlax-curve-getparamatpoint ee p))
            (setq pl2 (polyprocess nil ee p c))
            (setq pl2 (polyprocess t ee p c))
          )
          (vl-cmdf "_.PEDIT" "_M" (ssadd pl2 (ssadd pl1)) "" "_J" "" "")
          (if (vl-position pl1 xll)
            (setq xll (subst (entlast) pl1 xll))
            (setq xll (cons (entlast) xll))
          )
          (setq pxx
            (cons
              (progn
                (setq vl nil)
                (setq i (1+ (fix (+ 0.1 (vlax-curve-getendparam (entlast))))))
                (while (<= 0 (setq i (1- i)))
                  (setq vl (cons (vlax-curve-getpointatparam (entlast) (float i)) vl))
                )
              )
              pxx
            )
          )
        )
      )
    )

    (if (setq ss (ssget "_C" (setq pt (osnap pt "_nea")) pt (list (cons 0 "*POLYLINE"))))
      (progn
        (gc)
        (repeat (setq i (sslength ss))
          (if
            (and
              (not (vl-position (setq e (ssname ss (setq i (1- i)))) ell))
              (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-curve-getstartpoint) (list e))))
              (or
                (not (vl-some (function (lambda ( q ) (equal pt (trans q 0 1) 1e-6))) (apply (function append) pxx)))
                (and
                  (setq sss (ssget "_C" pt pt (list (cons 0 "*POLYLINE"))))
                  (progn
                    (foreach x (append xll ell)
                      (if (ssmemb x sss)
                        (ssdel x sss)
                      )
                    )
                    (and sss (> (sslength sss) 0))
                  )
                )
              )
            )
            (setq el (cons (list e pt) el))
          )
        )
        (if el
          (progn
            (setq ell (append (vl-remove-if (function (lambda ( x ) (vl-position x xll))) (mapcar (function car) el)) ell))
            (foreach ep el
              (setq f nil l nil)
              (setq e (car ep) pt (cadr ep))
              (setq d (vlax-curve-getdistatpoint e (trans pt 1 0)))
              (setq len (vlax-curve-getdistatparam e (vlax-curve-getendparam e)))
              (if (equal d len 1e-6)
                (setq d 0.0 f t)
              )
              (setq n (fix (setq par (vlax-curve-getparamatpoint e (vlax-curve-getclosestpointto e (trans pt 1 0))))))
              (if f
                (foreach p (reverse (repeat n (setq l (cons (trans (vlax-curve-getpointatparam e (float (1+ (fix (setq par (1- par)))))) 0 1) l))))
                  (proclst f len dd p)
                )
                (foreach p (reverse (repeat (- (fix (+ 0.1 (vlax-curve-getendparam e))) n) (setq l (cons (trans (vlax-curve-getpointatparam e (float (1- (fix (setq par (1+ par)))))) 0 1) l))))
                  (proclst f len dd p)
                )
              )
              (cond
                ( (and
                    (zerop d)
                    (= (cdr (assoc 90 (entget e))) 2)
                    (if f
                      (vlax-curve-getpointatdist e (- len dd))
                      (vlax-curve-getpointatdist e dd)
                    )
                  )
                  (if f
                    (progn
                      (entmake (list (cons 0 "POINT") (cons 10 (setq p (vlax-curve-getpointatdist e (- len dd))))))
                      (if (= ch "Yes") (makepoly f e p c))
                    )
                    (progn
                      (entmake (list (cons 0 "POINT") (cons 10 (setq p (vlax-curve-getpointatdist e dd)))))
                      (if (= ch "Yes") (makepoly f e p c))
                    )
                  )
                )
                ( (<= 0.0 (+ d dd) len)
                  (if f
                    (progn
                      (entmake (list (cons 0 "POINT") (cons 10 (setq p (vlax-curve-getpointatdist e (- len (+ d dd)))))))
                      (if (= ch "Yes") (makepoly f e p c))
                    )
                    (progn
                      (entmake (list (cons 0 "POINT") (cons 10 (setq p (vlax-curve-getpointatdist e (+ d dd))))))
                      (if (= ch "Yes") (makepoly f e p c))
                    )
                  )
                )
              )
            )
          )
        )
        (foreach lst processlst
          (process (car lst) (cadr lst))
        )
      )
    )
  )

  (if
    (and
      (setq pt (getpoint "\nPick or specify main base point : "))
      (setq bp pt)
      (not (initget 6))
      (setq dd (cond ( (not (setq dd (getdist pt "\nPick or specify length from base point for spread around <1.0> : "))) 1.0 ) ( t dd )))
      (not (initget "Yes No"))
      (setq ch (cond ( (not (setq ch (getkword "\nDo you want to overmake new polylines up to resulting points [Yes / No] <Yes> : "))) "Yes" ) ( t ch )))
      (if (= ch "Yes")
        (progn
          (initget 6)
          (setq c (cond ( (not (setq c (getint "\nSpecify color for new polylines <3> : "))) 3 ) ( t c )))
        )
        t
      )
    )
    (progn
      (vla-zoomextents (vlax-get-acad-object))
      (preprocess)
      (process dd pt)
    )
  )
  (princ)
)

 

Edited August 25, 2022 by marko_ribar

[reza]

Hi Dear Marko

I used your final code.
But the previous version worked better.
In the final code, when it is used a second time for another point, it affects the previous selection set. And it does not work on all branches.

Of course, I don't want to trouble you. Because the previous version works correctly.
I am sending the sample file.

 

Pipe Network.dwg

[marko_ribar]

All fixed and much cleaner and removed numerous lacks... My recommendation is to work with this code instead of my last one...

 

(defun c:pts_along_pipe_trees_by_length-new ( / *error* pea cad doc reversepoly preprocess process bp dd ch c ell xll ) ; ell xll - lexical globals

  (vl-load-com)

  (defun *error* ( m )
    (if pea
      (setvar 'peditaccept pea)
    )
    (if
      (and
        doc
        (= 8 (logand 8 (getvar 'undoctl)))
      )
      (vla-endundomark doc)
    )
    (if doc
      (vla-regen doc acactiveviewport)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun reversepoly ( curve / rlw r3dp rhpl )

    (defun rlw ( lw / e x1 x2 x3 x4 x5 x6 )
      ;; by ElpanovEvgeniy
      (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)
        )
      )
    )

    ;; Reverse 3DPOLYLINE - Marko Ribar, d.i.a.
    (defun r3dp ( 3dp / r3dppol typ )
      (defun r3dppol ( 3dp / v p pl sfa var )
        (setq v 3dp)
        (while (= (cdr (assoc 0 (entget (setq v (entnext v))))) "VERTEX")
          (setq p (cdr (assoc 10 (entget v))) pl (cons p pl))
        )
        (setq pl (apply (function append) pl) sfa (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length pl)))))
        (vlax-safearray-fill sfa pl)
        (setq var (vlax-make-variant sfa))
        (vla-put-coordinates (vlax-ename->vla-object 3dp) var)
        (entupd 3dp)
      )
      (setq typ (vla-get-type (vlax-ename->vla-object 3dp)))
      (vla-put-type (vlax-ename->vla-object 3dp) acsimplepoly)
      (r3dppol 3dp)
      (if typ (vla-put-type (vlax-ename->vla-object 3dp) typ))
      (entupd 3dp)
    )

    ;; Reverse old heavy 2d POLYLINE - Marko Ribar, d.i.a. - sub functions by Roy at Theswamp.org
    (defun rhpl ( hpl / KGA_List_Divide_3 KGA_List_IndexSeqMakeLength KGA_Geom_PolylineReverse )
      (defun KGA_List_Divide_3 ( lst / ret )
        (repeat (/ (length lst) 3)
          (setq ret (cons (list (car lst) (cadr lst) (caddr lst)) ret) lst (cdddr lst))
        )
        (reverse ret)
      )
      ; Make a zero based list of integers.
      (defun KGA_List_IndexSeqMakeLength ( len / ret )
        (repeat (rem len 4)
          (setq ret (cons (setq len (1- len)) ret))
        )
        (repeat (/ len 4)
          (setq ret (vl-list* (- len 4) (- len 3) (- len 2) (- len 1) ret) len (- len 4))
        )
        ret
      )
      ; Obj must be an "AcDb2dPolyline" of the acsimplepoly type or an "AcDbPolyline".
      (defun KGA_Geom_PolylineReverse ( obj / typ bulgeLst idxLst ptLst widLst conWid v vx )
        (setq typ (vla-get-type obj))
        (vla-put-type obj acsimplepoly)
        (setq ptLst (KGA_List_Divide_3 (vlax-get obj 'coordinates)) idxLst (KGA_List_IndexSeqMakeLength (1+ (length ptLst))) v (vlax-vla-object->ename obj))
        (while (= (cdr (assoc 0 (setq vx (entget (setq v (entnext v)))))) "VERTEX")
          (setq widLst (cons (list (cdr (assoc 40 vx)) (cdr (assoc 41 vx))) widLst) bulgeLst (cons (cdr (assoc 42 vx)) bulgeLst))
        )
        (if (vl-catch-all-error-p (setq conWid (vl-catch-all-apply (function vla-get-constantwidth) (list obj))))
          (mapcar
            (function (lambda ( idx pt bulge widSub )
              (vla-put-coordinate obj idx (vlax-3d-point pt))
              (vla-setbulge obj idx (- bulge))
              (vla-setwidth obj idx (cadr widSub) (car widSub))
            )) idxLst (reverse ptLst) (append (cdr bulgeLst) (list (car bulgeLst))) (append (cdr widLst) (list (car widLst)))
          )
          (progn
            (mapcar
              (function (lambda ( idx pt bulge widSub )
                (vla-put-coordinate obj idx (vlax-3d-point pt))
                (vla-setbulge obj idx (- bulge))
              )) idxLst (reverse ptLst) (append (cdr bulgeLst) (list (car bulgeLst)))
            )
            (vla-put-constantwidth obj conWid)
          )
        )
        (if typ (vla-put-type obj typ))
      )
      (KGA_Geom_PolylineReverse (vlax-ename->vla-object hpl))
      (entupd hpl)
    )

    (cond
      ( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDb2dPolyline") (rhpl curve) )
      ( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDb3dPolyline") (r3dp curve) )
      ( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDbPolyline") (rlw curve) )
    )
  )

  (defun preprocess ( e / uniquevbl ss ex i b vbl sa coords )

    (defun uniquevbl ( l )
      (if l
        (cons (car l)
          (uniquevbl
            (vl-remove-if
              (function (lambda ( x )
                (equal (caar l) (car x) 1e-6)
              )) (cdr l)
            )
          )
        )
      )
    )

    (if (or e (setq ss (ssget "_A" (list (cons 0 "*POLYLINE")))))
      (foreach pl (if e (list e) (vl-remove (function listp) (mapcar (function cadr) (ssnamex ss))))
        (setq ex (entget pl))
        (if
          (and
            (not e)
            (or
              (= (cdr (assoc 90 ex)) 1)
              (and
                (= (cdr (assoc 90 ex)) 2)
                (equal (cdr (assoc 10 ex)) (cdr (assoc 10 (reverse ex))) 1e-6)
              )
            )
          )
          (entdel pl)
        )
        (if (not (vlax-erased-p pl))
          (progn
            (setq vbl nil)
            (setq i (1+ (fix (+ 0.1 (vlax-curve-getendparam pl)))))
            (while (<= 0 (setq i (1- i)))
              (setq vbl (cons (list (vlax-curve-getpointatparam pl (float i)) (if (not (vl-catch-all-error-p (setq b (vl-catch-all-apply (function vla-getbulge) (list (vlax-ename->vla-object pl) i))))) b)) vbl))
            )
            (setq vbl (uniquevbl vbl))
            (if (= (cdr (assoc 0 ex)) "LWPOLYLINE")
              (progn
                (setq vbl (mapcar (function (lambda ( x ) (list (trans (car x) 0 (cdr (assoc 210 ex))) (cadr x)))) vbl))
                (setq ex (subst (cons 90 (length vbl)) (assoc 90 ex) ex))
                (setq ex
                  (append
                    (vl-remove-if
                      (function (lambda ( x )
                        (vl-position (car x) (list 10 40 41 42 91 210))
                      )) ex
                    )
                    (apply (function append)
                      (mapcar
                        (function (lambda ( x )
                          (list
                            (cons 10 (car x))
                            (cons 40 0.0)
                            (cons 41 0.0)
                            (cons 42 (cadr x))
                            (cons 91 0.0)
                          )
                        )) vbl
                      )
                    )
                    (list (assoc 210 ex))
                  )
                )
                (entupd (cdr (assoc -1 (entmod ex))))
              )
              (progn
                (setq sa (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length (setq coords (apply (function append) (mapcar (function car) vbl))))))))
                (vla-put-coordinates (vlax-ename->vla-object pl) (vlax-make-variant (vlax-safearray-fill sa coords)))
              )   
            )
          )
        )
      )
    )
  )  

  (defun process ( dd qt pt / proclst makepoly processlst ss i el e d len f par lst pp )

    (defun proclst ( e dd qt pt / pp par ddd )
      (if
        (and
          (setq par (float (fix (+ 0.1 (vlax-curve-getparamatpoint e (trans qt 1 0))))))
          (setq pp (vlax-curve-getpointatparam e par))
        )
        (progn
          (setq ddd (- dd (vlax-curve-getdistatpoint e pp)))
          (if (> ddd 0)
            (setq processlst (cons (list ddd qt pt) processlst))
          )
        )
      )
    )

    (defun makepoly ( e p c / polyprocess s eel el pl1 pl2 pl3 vl i qtt )

      (defun polyprocess ( e q c / f ln ep i pbl par b arcll arclx a ex )
        (setq ln (vlax-curve-getdistatparam e (setq ep (vlax-curve-getendparam e))))
        (repeat (setq i (1+ (fix (+ 0.1 ep))))
          (setq pbl
            (cons
              (list
                (vlax-curve-getpointatparam e (float (setq i (1- i))))
                (if (not (vl-catch-all-error-p (setq b (vl-catch-all-apply (function vla-getbulge) (list (vlax-ename->vla-object e) i))))) b)
              ) pbl
            )
          )
        )
        (setq par (vlax-curve-getparamatpoint e (vlax-curve-getclosestpointto e q)))
        (if (equal par ep 1e-6)
          (progn
            (reversepoly e)
            (entupd e)
            (setq f t)
          )
        )
        (setq pbl nil)
        (repeat (setq i (1+ (fix (+ 0.1 ep))))
          (setq pbl
            (cons
              (list
                (vlax-curve-getpointatparam e (float (setq i (1- i))))
                (if (not (vl-catch-all-error-p (setq b (vl-catch-all-apply (function vla-getbulge) (list (vlax-ename->vla-object e) i))))) b)
              ) pbl
            )
          )
        )
        (setq par (vlax-curve-getparamatpoint e (vlax-curve-getclosestpointto e q)))
        (if (and par pbl)
          (progn
            (if
              (and
                (vlax-curve-getpointatparam e (float (fix (1+ par))))
                (setq b (cadr (nth (fix par) pbl)))
              )
              (progn
                (setq arcll
                  (-
                    (vlax-curve-getdistatparam e (float (fix (1+ par))))
                    (vlax-curve-getdistatparam e (float (fix par)))
                  )
                )
                (setq arclx
                  (-
                    (vlax-curve-getdistatparam e par)
                    (vlax-curve-getdistatparam e (float (fix par)))
                  )
                )
                (setq a (* 4.0 (atan b)))
                (setq b (/ (sin (/ (* (/ a arcll) arclx) 4.0)) (cos (/ (* (/ a arcll) arclx) 4.0))))
              )
            )
            (setq pbl (reverse (member (nth (fix par) pbl) (reverse pbl))))
            (setq pbl (append (subst (list (car (last pbl)) b) (last pbl) pbl) (list (list q nil))))
            (setq ex (entget e))
            (if f
              (progn
                (reversepoly e)
                (entupd e)
              )
            )
            (if (vl-some (function numberp) (mapcar (function cadr) pbl))
              (entmakex
                (append
                  (list
                    (cons 0 "LWPOLYLINE")
                    (cons 100 "AcDbEntity")
                    (cons 100 "AcDbPolyline")
                    (cons 90 (length pbl))
                    (cons 70 (* 128 (getvar 'plinegen)))
                    (assoc 38 ex)
                  )
                  (apply (function append)
                    (mapcar
                      (function (lambda ( x )
                        (list
                          (cons 10 (trans (car x) 0 (cdr (assoc 210 ex))))
                          (cons 40 0.0)
                          (cons 41 0.0)
                          (cons 42 (if (cadr x) (cadr x) 0.0))
                          (cons 91 0.0)
                        )
                      )) pbl
                    )
                  )
                  (list
                    (assoc 210 ex)
                    (cons 62 c)
                  )
                )
              )
              (progn
                (vl-cmdf "_.3DPOLY")
                (foreach pb pbl
                  (vl-cmdf "_non" (trans (car pb) 0 1))
                )
                (vl-cmdf "")
                (entupd
                  (cdr
                    (assoc -1
                      (entmod
                        (if (assoc 62 (setq ex (entget (entlast))))
                          (subst (cons 62 c) (assoc 62 ex) ex)
                          (append ex (list (cons 62 c)))
                        )
                      )
                    )
                  )
                )
              )
            )
          )
        )
      )

      (setq xll (cons (setq pl1 (polyprocess e p c)) xll))
      (setq qtt (trans (vlax-curve-getpointatparam pl1 0.0) 0 1))
      (if
        (and
          (not (equal (trans qtt 1 0) (trans bp 1 0) 1e-6))
          (setq s (ssget "_C" (mapcar (function +) (list -1e-3 -1e-3) qtt) (mapcar (function +) (list 1e-3 1e-3) qtt) (list (cons 0 "*POLYLINE"))))
          (> (sslength s) 0)
        )
        (progn
          (if (ssmemb e s)
            (ssdel e s)
          )
          (if (ssmemb pl1 s)
            (ssdel pl1 s)
          )
          (foreach x xll
            (if (and s (ssmemb x s))
              (ssdel x s)
            )
          )
          (if (and s (> (sslength s) 0))
            (setq eel (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s))))
          )
        )
      )
      (foreach ee eel
        (setq f nil)
        (setq pl3 (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object pl1))))
        (if (< (vlax-curve-getparamatpoint ee (trans bp 1 0)) (vlax-curve-getparamatpoint ee (trans qtt 1 0)))
          (setq pl2 (polyprocess ee qtt c))
          (progn
            (reversepoly ee)
            (entupd ee)
            (setq pl2 (polyprocess ee qtt c))
            (setq f t)
          )
        )
        (if f
          (progn
            (reversepoly ee)
            (entupd ee)
          )
        )
        (setq el (entlast))
        (if (and pl2 pl3)
          (progn
            ;|
            (vl-cmdf "_.PEDIT" "_M" (ssadd pl2 (ssadd pl3)) "" "_J")
            (while (< 0 (getvar 'cmdactive))
              (vl-cmdf "")
            )
            |;
            (vl-cmdf "_.JOIN" (ssadd pl2 (ssadd pl3)) "")
            (if (not (eq el (entlast)))
              (setq el (entlast))
              (setq el (if pl2 pl2 pl3))
            )
            (preprocess el)
            (if (vl-position pl1 xll)
              (setq xll (subst el pl1 xll))
              (setq xll (cons el xll))
            )
          )
        )
      )
      (if (and eel pl1 (not (vlax-erased-p pl1)))
        (entdel pl1)
      )
    )

    (if
      (and
        (setq ss (ssget "_C" (mapcar (function +) (list -1e-3 -1e-3) (setq qt (osnap qt "_nea"))) (mapcar (function +) (list 1e-3 1e-3) qt) (list (cons 0 "*POLYLINE"))))
        (progn
          (foreach x (append xll ell)
            (if (ssmemb x ss)
              (ssdel x ss)
            )
          )
          (and ss (> (sslength ss) 0))
        )
      )
      (progn
        (repeat (setq i (sslength ss))
          (if
            (and
              (not (vl-position (setq e (ssname ss (setq i (1- i)))) ell))
              (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-curve-getstartpoint) (list e))))
            )
            (setq el (cons (list e pt) el))
          )
        )
        (if el
          (progn
            (setq ell (append (vl-remove-if (function (lambda ( x ) (vl-position x xll))) (mapcar (function car) el)) ell))
            (foreach ep el
              (setq f nil lst nil)
              (setq e (car ep) pt (cadr ep))
              (setq d (vlax-curve-getdistatpoint e (trans qt 1 0)))
              (setq len (vlax-curve-getdistatparam e (vlax-curve-getendparam e)))
              (if (equal d len 1e-6)
                (progn
                  (reversepoly e)
                  (entupd e)
                  (setq f t)
                )
              )
              (setq d (vlax-curve-getdistatpoint e (trans qt 1 0)))
              (repeat (setq par (fix (+ 0.1 (vlax-curve-getendparam e))))
                (setq lst
                  (cons
                    (trans (vlax-curve-getpointatparam e (float (1+ (fix (setq par (1- par)))))) 0 1)
                    lst
                  )
                )
              )
              (foreach p lst
                (proclst e dd p pt)
              )
              (cond
                ( (and
                    (zerop d)
                    (= (cdr (assoc 90 (entget e))) 2)
                    (vlax-curve-getpointatdist e dd)
                  )
                  (if (and e (not (vlax-erased-p e)) (setq pp (vlax-curve-getpointatdist e dd)))
                    (progn
                      (entmake (list (cons 0 "POINT") (cons 10 pp)))
                      (if (= ch "Yes") (makepoly e pp c))
                    )
                  )
                )
                ( (<= 0.0 (+ d dd) len)
                  (if (and e (not (vlax-erased-p e)) (setq pp (vlax-curve-getpointatdist e (+ d dd))))
                    (progn
                      (entmake (list (cons 0 "POINT") (cons 10 pp)))
                      (if (= ch "Yes") (makepoly e pp c))
                    )
                  )
                )
              )
              (if f
                (progn
                  (reversepoly e)
                  (entupd e)
                )
              )
            )
          )
        )
        (foreach lst processlst
          (process (car lst) (cadr lst) (caddr lst))
        )
      )
    )
  )

  (setq pea (getvar 'peditaccept))
  (setvar 'peditaccept 1)
  (if
    (and
      (setq doc (vla-get-activedocument (setq cad (vlax-get-acad-object))))
      (= 8 (logand 8 (getvar 'undoctl)))
    )
    (vla-endundomark doc)
  )
  (if doc
    (vla-startundomark doc)
  )
  (if
    (and
      (setq bp (getpoint "\nPick or specify main base point : "))
      (not (initget 6))
      (setq dd (cond ( (not (setq dd (getdist bp "\nPick or specify length from base point for spread around <1.0> : "))) 1.0 ) ( t dd )))
      (not (initget "Yes No"))
      (setq ch (cond ( (not (setq ch (getkword "\nDo you want to overmake new polylines up to resulting points [Yes / No] <Yes> : "))) "Yes" ) ( t ch )))
      (if (= ch "Yes")
        (progn
          (initget 6)
          (setq c (cond ( (not (setq c (getint "\nSpecify color for new polylines <3> : "))) 3 ) ( t c )))
        )
        t
      )
    )
    (progn
      (if cad
        (vla-zoomextents cad)
      )
      (preprocess nil)
      (process dd bp bp)
    )
  )
  (*error* nil)
)

 

Regards, M.R.

HTH.

Edited August 26, 2022 by marko_ribar

[marko_ribar]

I've corrected my last version and it should be fully operational and ready for usage... If you still find some lacks, please report...

M.R.