Stretch multiple base point polylines to different distance

Hi all,

Is this possible to stretch polylines with multiple base point to different distance but same direction?

M4rdy

Quick answer YES, using a lisp etc

ask which point to move your example would be vertice 2

using "intersectwith" new pt intersection of red & green

redo pline vertices adjusting x,y

Code sorry dont have anything. need some time some one else may jump in.

I'm still trying and spend a lot of time to find solution.

But still no luck.

(defun c:Test1 (/ ent lst)
 (if
   (and (setq toLine (vlax-ename->vla-object (car (entsel "\nSelect Line: "))))
    (setq p1 (getpoint "\nSpecify First Point: "))
    (setq p2 (getpoint "\nSpecify Second Point: " p1))
    (setq ss (apply 'ssget
                          (append (list "_C")
                                  (mapcar '(lambda (foo) (apply 'mapcar (cons foo (list p1 p2))))
                                          '(min max)
                                  )
                                  (list '((0 . "*LINE")))
                          )
                   )
          )
    
          (setq lst0 ((lambda (l / i)
                       (setq i (lm:getobjintersectionsinss l ss))
                       (vla-delete l)
                       i
                     )
                      (vlax-ename->vla-object
                        (entmakex (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2)))
                      )
                    )
          )
   )
    (progn
      (setq lst1 (mapcar 'cons (mapcar 'cadr (ssnamex ss)) lst0))
      (setq i 0)
      (repeat (sslength ss)
    (setq e (ssname ss i))
    (setq lst (cadr (at:segment int_f)))
    (setq Pintobj (LM:GetIntersections
            toLine
            (vlax-ename->vla-object e)
              )
    )
    (vl-cmdf "_.stretch"
         ss
         ""
         "_non"
         (trans lst 0 1)
         (trans (car Pintobj) 0 1)
    )
    (setq i (1+ i))
      )
    )
 )
 (princ)
)

(defun lm:getobjintersectionsinss (obj ss)
 ;; © Lee Mac 2010
 ((lambda (i / j a b ilst)
    (while (setq e (ssname ss (setq i (1+ i))))
      (setq ilst (append ilst
                         (lm:groupbynum (vlax-invoke obj
                                                     'intersectwith
                                                     (vlax-ename->vla-object e)
                                                     acextendnone
                                        )
                                        3
                         )
                 )
      )
    )
  )
   -1
 )
)

(defun AT:Segment (entPnt)
 ;; Retreive segment number and Start & End points
 ;; entPnt - List with entity (ENAME or VLA-OBJECT) & point
 ;; Alan J. Thompson, 11.10.09 / 08.19.10 / 11.15.11
 (if (vl-consp entPnt)
   ((lambda (e p / n)
      (if (setq n (vlax-curve-getPointAtParam e (1+ p)))
        (list p (list (vlax-curve-getPointAtParam e p) n))
        (list p (list (vlax-curve-getPointAtParam e (1- p)) (vlax-curve-getPointAtParam e p)))
      )
    )
     (car entPnt)
     (fix (vlax-curve-getParamAtPoint
            (car entPnt)
            (vlax-curve-getClosestPointToProjection
              (car entPnt)
              (trans (cadr entPnt) 1 (car entPnt))
              '(0. 0. 1.)
            )
          )
     )
   )
 )
)

Finally it works, although far from perfect.

(defun c:Test2 (/ toLine p1 p2 ss lst0 lst1 Pintobj vtx_pline list_vtx_pline)
 (if
   (and (setq toLine
       (vlax-ename->vla-object (car (entsel "\nSelect Line: ")))
    )
    (setq p1 (getpoint "\nSpecify First Point: "))
    (setq p2 (getpoint "\nSpecify Second Point: " p1))
    (setq ss
       (apply
         'ssget
         (append
           (list "_C")
           (mapcar
             '(lambda (foo) (apply 'mapcar (cons foo (list p1 p2))))
             '(min max)
           )
           (list '((0 . "*LINE")))
         )
       )
    )
    (setq
      lst0    ((lambda (l / i)
          (setq i (lm:getobjintersectionsinss l ss))
          (vla-delete l)
          i
        )
         (vlax-ename->vla-object
           (entmakex
             (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2))
           )
         )
       )
    )
   ) ;_and
    (progn
      ;; Find intersection between line and selection
      (setq Pintobj (lm:getobjintersectionsinss toLine ss))

      ;;(princ Pintobj) ;_for testing

      (setq cadrm (mapcar 'cadr (ssnamex ss)))

      ;; Make list (ename point_intersection)
      (setq lst1 (mapcar 'list cadrm lst0))

      (foreach    n lst1
    (setq p (fix
          (vlax-curve-getparamatpoint
            (car n)
            (vlax-curve-getclosestpointtoprojection
              (car n)
              (trans (cadr n) 1 0)
              '(0.0 0.0 1.0)
            )
          )
        )
    ) ;_setq p
    (setq vtx_pline
       (list
         (trans (vlax-curve-getpointatparam (car n) p) 0 1)
       )
    )

    ;;(princ vtx_pline) ;_for testing

    (setq list_vtx_pline (append list_vtx_pline vtx_pline)) ;_This is Start point of Selected Segment PLINES as base point of STRETCH:

      ) ;_foreach
      ;;(princ list_vtx_pline) ;_for testing

      (setq data (mapcar 'list cadrm list_vtx_pline pintobj))

      (foreach    m data
    (vl-cmdf "_.stretch"
         (car m)
         ""
         "_non"
         (cadr m)
         (caddr m)
    )
      )
    ) ;_progn
 ) ;_if
 (princ)
) ;_defun


(defun lm:getobjintersectionsinss (obj ss)
 ;; © Lee Mac 2010
 ((lambda (i / j a b ilst)
    (while (setq e (ssname ss (setq i (1+ i))))
      (setq ilst (append ilst
             (lm:groupbynum
               (vlax-invoke
                 obj
                 'intersectwith
                 (vlax-ename->vla-object e)
                 acextendnone
               )
               3
             )
         )
      )
    )
  )
   -1
 )
)

;;  Author: Lee Mac, Copyright © 2010 - www.lee-mac.com       ;;
(defun LM:GroupByNum (l n / r)
 (if l
   (cons
     (reverse (repeat n
        (setq r (cons (car l) r)
              l (cdr l)
        )
        r
          )
     )
     (LM:GroupByNum l n)
   )
 )
)

Having a think about this I nearly redid it a lot shorter but it had two flaws, asking for the vertice position and the second more important, once the plines are rotated totally different method required. Thinking about it now using a UCS may get around this problem. Also need to pick the end to move is it left or right ? This can be done pretty easy by reversing the pline vertice order, is it beyond the new int point.

Here is a better way to do the line pick part, I have guessed thats its a temporary line, if it exists already then just pick the line and use fence. Plus the start of a different way to do it.

(setq pt1 (getpoint "Pick 1st crossing point"))
(setq pt2 (getpoint Pt1 "Pick 2nd crossing point"))
(setq vert (getint "Enter vertice position 2+ etc ")) ; do a left or right here pick end instead.
(setq ss (ssget "F" (list pt1 pt2))) ; selection set of plines

(command "Line" pt1 pt2 "") ; do after select or else line is added
(setq objL (vlax-Ename->Vla-Object (entlast))) ; saves line object for intersect erase at end.

; pline co-ords example
; By Alan H
(defun getcoords (ent)
 (vlax-safearray->list
   (vlax-variant-value
     (vlax-get-property
   (vlax-ename->vla-object ent)
   "Coordinates"
     )
   )
 )
)

; work in progress
(repeat (setq K (sslength ss)) ; loop through
(setq co-ords (getcoords (ssname ss (setq k (- k 1))))) ; pline co-ords ; uses getcoords defun
(setq objpl (vlax-Ename->Vla-Object (ssname ss k)))
(setq intpt1 (vlax-invoke objpl 'intersectWith objL acExtendThisEntity))
(setq x (car intpt1))
(setq y (cadr intpt1))

; do the ucs bit here erase line UCS OB then oops does it work 

(setq newlst '())
(setq len2 (length co-ords))

(repeat vert
(setq newlst (cons (list x (nth (setq len2 (- len2 1)) co-ords)) newlst))
) ; repeat vert
; add remaining pts 
(repeat (- len2 vert)
(setq newlst (cons (list x (nth (setq len2 (- len2 1)) co-ords)) newlst))
) ; repeat remainder

; erase pline and draw new pline
(setq J 0)
(command "pline" 
(repeat (length newlst)
(list (nth J newlst)(nth (+ J 1) newlst))
(setq J (+ J  2))
)

) ;repeat ss

A more universal approach would be better so we dont get the next post, "can it be changed for on angle".

Hi BIGAL,

Thank you for your help.

I don't know if i'm missing something, but if i run your code there is error on "command "Pline"".

(defun c:Test2 (/ pt1 pt2 vert ss objL K co-ords objpl intpt1 x y newlst len2)
 ;; http://www.cadtutor.net/forum/showthread.php?97882-Stretch-multiple-base-point-polylines-to-different-distance
 ;; BIGAL
 (setq pt1 (getpoint "Pick 1st crossing point"))
 (setq pt2 (getpoint Pt1 "Pick 2nd crossing point"))
 (setq vert (getint "Enter vertice position 2+ etc ")) ;_ do a left or right here pick end instead.
 (setq ss (ssget "F" (list pt1 pt2))) ;_ selection set of plines
 (command "Line" pt1 pt2 "") ;_ do after select or else line is added
 (setq objL (vlax-Ename->Vla-Object (entlast))) ;_ saves line object for intersect erase at end.
 ;; pline co-ords example
 ;; By Alan H
 (defun getcoords (ent)
   (vlax-safearray->list
     (vlax-variant-value
   (vlax-get-property
     (vlax-ename->vla-object ent)
     "Coordinates"
   ) ;_end of vlax-get-property
     ) ;_end of vlax-variant-value
   ) ;_end of vlax-safearray->list
 ) ;_end of defun


 ;; work in progress
 (repeat (setq K (sslength ss)) ;_ loop through
   (setq co-ords (getcoords (ssname ss (setq k (- k 1))))) ;_ pline co-ords ; uses getcoords defun
   (setq objpl (vlax-Ename->Vla-Object (ssname ss k)))
   (setq intpt1 (vlax-invoke objpl 'intersectWith objL acExtendThisEntity))
   (setq x (car intpt1))
   (setq y (cadr intpt1))

   ;; do the ucs bit here erase line UCS OB then oops does it work 

   (setq newlst '())
   (setq len2 (length co-ords))

   (repeat vert
     (setq newlst (cons (list x (nth (setq len2 (- len2 1)) co-ords))
            newlst
          ) ;_end of cons
     ) ;_end of setq
   ) ;_ repeat vert
   ;; add remaining pts 
   (repeat (- len2 vert)
     (setq newlst (cons (list x (nth (setq len2 (- len2 1)) co-ords))
            newlst
          ) ;_end of cons
     ) ;_end of setq
   ) ;_ repeat remainder

   ;; erase pline and draw new pline
   (setq J 0)
   (command "pline"
        (repeat (length newlst)
          (list (nth J newlst) (nth (+ J 1) newlst))
          (setq J (+ J 2))
        ) ;_end of repeat
   ) ;_end of command
 ) ;_repeat ss
 (princ)
) ;_defun

A more universal approach would be better so we dont get the next post, "can it be changed for on angle".

The next 'call of duty' ..

Like it says "a work in progress" I knew I had one out there not finished but had to do some real work. Will get time over the weekend as they are predicting rain will see what I can do.

A couple of rules/questions will the pline always be the same shape basicly copied by that all have 4 pts v's 1 with 3 pts etc