Topic: Stretch multiple base point polylines to different distance

[m4rdy]

Hi all,

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


m4rdy

[m4rdy]

I'm glad it works although far from perfect.

Code: [Select]

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

m4rdy

[m4rdy]

Duh,
Spoke too soon.
My code is just moving all pline, not stretching like what i want.
 

[xdcad]

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

[ribarm]

Code - Auto/Visual Lisp: [Select]

1. (defun c:stretch-vert-curve ( / ptonline rlw ss s c sn ip pts ptt vec ptn k n enx )
2.  
3.   (vl-load-com)
4.  
5.   (defun ptonline ( p1 p p2 )
6.     (equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-8)
7.   )
8.  
9.   (defun rlw ( lw / e x1 x2 x3 x4 x5 x6 )
10.     ;; by ElpanovEvgeniy
11.     (if (= (cdr (assoc 0 (setq e (entget lw)))) "LWPOLYLINE")
12.       (progn
13.         (foreach a1 e
14.           (cond
15.             ( (= (car a1) 10) (setq x2 (cons a1 x2)) )
16.             ( (= (car a1) 40) (setq x4 (cons (cons 41 (cdr a1)) x4)) )
17.             ( (= (car a1) 41) (setq x3 (cons (cons 40 (cdr a1)) x3)) )
18.             ( (= (car a1) 42) (setq x5 (cons (cons 42 (- (cdr a1))) x5)) )
19.             ( (= (car a1) 210) (setq x6 (cons a1 x6)) )
20.             ( t (setq x1 (cons a1 x1)) )
21.           )
22.         )
23.         (entmod
24.           (append (reverse x1)
25.             (append
26.               (apply 'append
27.                 (apply 'mapcar
28.                   (cons 'list
29.                     (list x2
30.                       (cdr (reverse (cons (car x3) (reverse x3))))
31.                       (cdr (reverse (cons (car x4) (reverse x4))))
32.                       (cdr (reverse (cons (car x5) (reverse x5))))
33.                     )
34.                   )
35.                 )
36.               )
37.               x6
38.             )
39.           )
40.         )
41.         (entupd lw)
42.       )
43.     )
44.   )
45.  
46.   (if
47.     (and
48.       (not (prompt "\nSelect objects with vertices you want to stretch - you must select window where vertices are placed - polyline must have start, middle and end vertices..."))
49.       (setq ss (ssget "_:L" '((0 . "LWPOLYLINE"))))
50.       (not (prompt "\nNow pick boundary curve you want vertices to stretch to..."))
51.       (setq s (ssget "_+.:E:S"))
52.     )
53.     (progn
54.       (setq c (ssname s 0))
55.       (setq sn (ssnamex ss))
56.       (setq sn (vl-remove-if '(lambda ( x ) (= (length x) 4)) sn))
57.       (setq sn (mapcar 'cadr (cdar sn)))
58.       (setq sn (mapcar '(lambda ( x ) (list (car x) (cadr x))) sn))
59.       (foreach pl (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
60.         (setq pts (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (setq enx (entget pl)))))
61.         (setq n (length pts))
62.         (if (< (caar pts) (car (last pts)))
63.           (progn
64.             (rlw pl)
65.             (setq pts (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (setq enx (entget pl)))))
66.           )
67.         )
68.         (setq ptt (vl-remove-if-not '(lambda ( x ) (and (< (apply 'min (mapcar 'car sn)) (car x) (apply 'max (mapcar 'car sn))) (< (apply 'min (mapcar 'cadr sn)) (cadr x) (apply 'max (mapcar 'cadr sn))))) pts))
69.         (setq ip (vlax-invoke (vlax-ename->vla-object c) 'intersectwith (vlax-ename->vla-object pl) acextendnone))
70.         (setq ip (list (car ip) (cadr ip)))
71.         (setq k -1)
72.         (foreach p pts
73.           (setq k (1+ k))
74.           (if (and (<= (1+ k) (1- (length pts))) (ptonline (nth k pts) ip (nth (1+ k) pts)))
75.             (progn
76.               (if (and (< (apply 'min (mapcar 'car sn)) (car (nth k pts)) (apply 'max (mapcar 'car sn))) (< (apply 'min (mapcar 'cadr sn)) (cadr (nth k pts)) (apply 'max (mapcar 'cadr sn))))
77.                 (setq vec (mapcar '- ip (nth k pts)))
78.                 (setq vec (mapcar '- ip (nth (1+ k) pts)))
79.               )
80.               (setq ptn (mapcar '(lambda ( x ) (mapcar '+ vec x)) ptt))
81.               (if (and (< (apply 'min (mapcar 'car sn)) (car (nth k pts)) (apply 'max (mapcar 'car sn))) (< (apply 'min (mapcar 'cadr sn)) (cadr (nth k pts)) (apply 'max (mapcar 'cadr sn))))
82.                 (setq pts (append ptn (vl-remove-if '(lambda ( x ) (vl-some '(lambda ( y ) (equal x y 1e-6)) ptt)) pts)))
83.                 (setq pts (append (vl-remove-if '(lambda ( x ) (vl-some '(lambda ( y ) (equal x y 1e-6)) ptt)) pts) ptn))
84.               )
85.               (setq enx (append (reverse (member (assoc 38 enx) (reverse enx))) (apply 'append (mapcar '(lambda ( p ) (list (cons 10 p) (cons 40 0.0) (cons 41 0.0) (cons 42 0.0) (cons 91 0))) pts)) (list (list 210 0.0 0.0 1.0))))
86.               (entupd (cdr (assoc -1 (entmod enx))))
87.               (setq enx (entget pl))
88.               (if (> (cdr (assoc 90 enx)) n)
89.                 (progn
90.                   (setq k (- (cdr (assoc 90 enx)) n))
91.                   (setq enx (subst (cons 90 n) (assoc 90 enx) enx))
92.                   (repeat k
93.                     (setq enx (append (reverse (cdr (vl-member-if '(lambda ( x ) (equal (assoc 10 (reverse enx)) x 1e-6)) (reverse enx)))) (list (list 210 0.0 0.0 1.0))))
94.                   )
95.                   (entupd (cdr (assoc -1 (entmod enx))))
96.                 )
97.               )
98.             )
99.           )
100.         )
101.       )
102.     )
103.   )
104.   (princ)
105. )
106.  

HTH.
M.R.

[JGA]

(defun c:stretch-vert-curve

HTH.
M.R.

Thanks for sharing. It only seems to work with a single crossing box, multiple selections or the crossing lasso seems to fox the routine.
This is working with AutoCAD LT 2024.

[ribarm]

I think that reverse lwpoly isn't necessary, but I'll leave it in routine to make every lwpoly oriented the same direction...

[ribarm]

(defun c:stretch-vert-curve

HTH.
M.R.

Thanks for sharing. It only seems to work with a single crossing box, multiple selections or the crossing lasso seems to fox the routine.
This is working with AutoCAD LT 2024.

I think it should be fine now and with lasso selection... Thanks for feedback...

[JGA]

I think it should be fine now and with lasso selection... Thanks for feedback...

Thanks for looking at the routine. It works perfectly with a crossing window, but the lasso crossing still seems to muck up the polylines when the line is to the left of the selected alignment line. It works fine with selecting polylines to the right of the alignment line.
I presume it's a limitation of how AutoCAD works out the crossing area with the lasso.

A small characteristic is that pressing Ctrl-Z will undo the action plus one more - i.e. if the last item I did was draw a line before starting stretch-vert-curve, pressing undo would delete the line.

[ribarm]

I think it should be fine now and with lasso selection... Thanks for feedback...

Thanks for looking at the routine. It works perfectly with a crossing window, but the lasso crossing still seems to muck up the polylines when the line is to the left of the selected alignment line. It works fine with selecting polylines to the right of the alignment line.
I presume it's a limitation of how AutoCAD works out the crossing area with the lasso.

A small characteristic is that pressing Ctrl-Z will undo the action plus one more - i.e. if the last item I did was draw a line before starting stretch-vert-curve, pressing undo would delete the line.

On my BricsCAD it works from both sides and with lasso selection... Watch attached animated *.gif...