Rotate with stretch program combination

[Tolearnlisp]

Hello Everyone,

Is it possible to have stretch+rotate combination in one command?

 

I want to rotate the object found at the center at any angle but I would want the inner endpoints of the polyline move along with the rotated object and the outer endpoint would stay in the same location. It is like stretch function but instead of just moving of what you have selected you have option to rotate it. Thank you

See attached cad file for your reference

[Sea-Haven]

This is my attempt it does need layer control as your inner box is 4 lines need a few picks, if it was always a pline then 1 pick would be all. basicly pick Lower left outside inner box, pick upper right outside inner box, pick box diag corners, drag or enter angle.

;  https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/rotate-with-stretch-program-combination/td-p/10088960/page/2
; By Alan H info@alanh.com.au Feb 2021

(defun c:romatch ( / ss ss2 X Y lst CO-ORD EN ENT LEN LST2 MPT NEW_COORD1 OLDSNAP PLEN PT1 PT2 PTL PTR)
(setq oldsnap (getvar 'osmode))
(SETVAR 'OSMODE 0)

(setq ptL(getpoint "\nPick lower left") ptR (getpoint ptl "\nPick upper right"))

(setq ss (ssget "WP" (list ptl (list (car ptr) (cadr ptl)) ptr (list (car ptl)(cadr ptr)) )))
(setq ss2 (ssget "WP" (list ptl (list (car ptr) (cadr ptl)) ptr (list (car ptl)(cadr ptr)) )))

(repeat (setq x (sslength ss))
(setq en (ssname ss (setq x (- x 1))))
(setq len (vla-get-length (vlax-ename->vla-object en)))
(if (> len 0.5) (setq ss (ssdel en ss)))
)

(setq lst '())
(repeat (setq x (sslength ss))
(setq en (ssname ss (setq x (- x 1))))
(setq co-ord (mapcar 'cdr (vl-remove-if-not '(lambda (y) (= (car y) 10)) (entget en))))
(setq lst (cons (list co-ord en) lst))
)

(setq lst2 '())
(repeat (setq x (length lst))
(command "undo" "be")
(command "erase" (nth 1 (nth (setq x (- x 1)) lst)) "")
(setq SS (ssget "CP" (nth 0 (nth x lst))))
(princ (sslength ss))
(command "undo" "b")
(setq en (ssname ss 0))
(setq co-ord (mapcar 'cdr (vl-remove-if-not '(lambda (y) (= (car y) 10)) (entget en))))
(if (< (distance (nth 0 co-ord) (nth 0 (nth 0 (nth x lst)))) 0.05)
(princ)
(command "pedit" en "R" "")
)
(setq lst2 (cons en lst2))
)

(setvar 'osmode 1)
(setq pt (mapcar '* (mapcar '+ (getpoint "\npick point 1") (getpoint "\npick point 2")) '(0.5 0.5)))
(command "rotate" ss2 "" pt pause)

(setvar 'osmode 0)
(repeat (setq x (length lst))
(setq ent (nth 1 (nth (setq x (- x 1)) lst)))
(setq co-ord (mapcar 'cdr (vl-remove-if-not '(lambda (y) (= (car y) 10)) (entget ent))))
(setq pt1 (nth 0 co-ord) pt2 (nth 2 co-ord))
(setq mpt (mapcar '+ pt1 pt2))
(setq mpt (mapcar '(lambda (y) (/ y 2.0)) mpt))
(setq mpt (list (car mpt) (cadr mpt)))
(setq plen (vlax-ename->vla-object (nth x lst2)))
(setq new_coord1 (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbdouble '(0 . 1)) mpt)))
(vla-put-coordinate plen 0 new_coord1)
)

(setvar 'osmode oldsnap)

(princ)
)

(c:romatch)

[Tolearnlisp]

Hello @ВeekeeCZ,
Thank you for your time. This codes are now fine to me and it will help me a lot.
It works on my testing (for without block close PL and with blocks PL)

[Tolearnlisp]

Hi @pbejse ,

You've got what I'm expecting. Many thanks to you.

One last thing I would like to ask is that, In the case of the attached new drawing, the little square with text inside of it are now in blocks and sometimes we got this kind of drawing. Code it be possible for the code to be modified to work with this oneor it will require a totally different sets of code? It's ok to me if this is the case. Thanks

[pbejse · Accepted solution]

---

@Tolearnlisp wrote:

One last thing I would like to ask is that, ....

...Code it be possible for the code to be modified to work with this...

---

Is it really the last thing? 😊

Nevertheless, here it is.

command:Twisty < - not to be confused with its cousin "twisted" 

Refer to attached Twisty.lsp [ works for both situations ]

[Déjà vu]

[Tolearnlisp]

Hi @pbejse ,

Thank you very much for your time and patience with me on the back and forth communication until you came up with the perfect code for my needs. I know I can't pay you back for now but thanking you is the least thing I can do.

After my testing, you're twisty code works perfectly in both cases and this will help us a lot.

As promised, this is my last thing not in the forum but with this subject/topic alone. More power

[Tolearnlisp]

Please Disregard

[Tolearnlisp]

Could anyone here help me by adding additional lines on the below code that when press ESCAPE it will cancel or undo the program. Currently, when I press escape it will stop on the middle of the program and I need to press ctrl+Z to back on the beginning.

@pbejse This is your code Twisty.lsp and I'm seeking to add ESCAPE function to cancel the program like most of the program do.

(Defun c:Twisty ( / _sort rotate_about_point _FollowThePlate _Looper
mxv e ent obj ap stretchy pbox gr data code)
;; pBe Feb 2021 | Rotate with stretch ;;

(defun rotate_about_point ( p b a )
;; pBe | LeeMAc 2021 ;;
( (lambda ( m ) (mapcar '+ (mxv m p) (mapcar '- b (mxv m b))))
(list
(list (cos a) (- (sin a)))
(list (sin a) (cos a))
)
)
)
(defun _FollowThePlate (l a / ev nsp nwp sp_ep)
(mapcar '(lambda (j)
(setq ev (car j) sp_ep (cadr j))
(Setq nsp (trans (rotate_about_point (Car sp_ep) ap a) 1 0))
(Vlax-put ev 'Coordinates
(append (list (Car nsp)(cadr nsp)) (cadr sp_eP)))
(list ev (list nsp (Cadr sp_ep))))
l
)
)

(defun _Looper (selset U_ang m )
(redraw)
(foreach itm
(mapcar 'vlax-ename->vla-object
(vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))
)
(Vlax-invoke itm 'Rotate ap (- U_ang ang))
)
(setq stretchy (_FollowThePlate stretchy (- U_ang ang)))
(setq ang U_ang)
(and m (grdraw ap data 1))
(setq n (/ (* ang 180.0) pi))
(princ (strcat "\nCurrent angle <Rotation/Any key to end>: "
(rtos (if (>= n 180) (- n 360) n) 2 0)))
m
)

;; Matrix x Vector - Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n

(defun mxv ( m v )
(mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)

(setq _sort (lambda (l s)
(vl-sort l '(lambda (a b)(s (car a)(car b))))))

(if (setq stretchy nil pBox nil gss (ssadd) ss (ssget "_:L" ))
(progn
(repeat (setq i (sslength ss))
(setq e (ssname ss (setq i (1- i)))
ent (entget e)
obj (cdr (assoc 0 ent))
)
(cond
((and (eq "LWPOLYLINE" obj)
(setq pts (mapcar 'cdr
(vl-remove-if-not
'(lambda (d) (= (Car d) 10))
ent
)
)
)
(= (length pts) 2)
)
(setq stretchy
(cons (list (vlax-ename->vla-object e) pts)
stretchy
)
)(ssdel e ss)
)
((eq "LWPOLYLINE" obj)
(setq Pbox (cons (list (vlax-curve-getarea e) e
(mapcar (function (lambda (a b) (* (+ a b) 0.5))) (car pts)(caddr pts)))
Pbox))
)
)
)

(setq ap (append (caddar (_sort Pbox >)) '(0.0)) ang 0.0)
(setq stretchy (mapcar '(lambda (w)
(list (Car w) (mapcar 'cadr
(_sort (mapcar '(lambda (m)
(list (distance ap m) m)) (cadr w)) <)))) stretchy))
(while
(progn
(setq gr (grread t 15 0)
code (car gr)
data (cadr gr)
)
(cond
((= 5 code)
(_looper ss (angle ap (cadr gr)) t)
)
((and (= 2 code) (member data '(82 114)))
(redraw)
(initget 7)
(setq U_angle (getangle " R\nEnter Angle: "))
(_looper ss U_angle nil)
)
((or (= 3 code) (= 2 code))
(redraw)
)
)
)
)
)
)(princ)
)