Polar stretch

[Shahin]

Hello all,

 

Does anyone knows a way to perform a stretch command but instead of stretching in rectangular dimension, rotate them around a center point with a number of degrees.

If there is a way to rewrite Stretch command in AutoLISP, it will be fairly easy to change it to polar version of it.

This is who it would work:

 

 

Thanks.

[alanjt]

1. Select the object to display Grips.
   
2. Shift-Select grips you want to move.
   
3. Select grip for basepoint.
   
4. Alter object...

eg.

[Lee Mac]

I suppose this comes close:

 

(defun c:PolarStretch ( / sel p- p+ ang pivot dis obj data gr )
 ;; © Lee Mac 2010
 (vl-load-com)

 (if (and (setq sel (entsel "\nSelect LWPoly: "))
          (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car sel))))))
   (progn
     (setq p- (fix (vlax-curve-getParamatPoint (setq ent (car sel))
                     (vlax-curve-getClosestPointto ent (cadr sel)))))

     (setq p+ (1+ p-) pivot (vlax-curve-getPointatParam ent (+ p- 0.5)))

     (setq ang (angle pivot (vlax-curve-getPointatParam ent p+))
           dis (distance pivot (vlax-curve-getPointatParam ent p+)))

     (setq obj (vlax-ename->vla-object ent))

     (while (= 5 (car (setq gr (grread 't 13 0)))) (redraw)
       (setq data (trans (cadr gr) 1 0))

       (mapcar
        '(lambda ( parameter a )
           (vla-put-Coordinate obj parameter
             (LM:PointVariant
               (list
                 (2DPoint
                   (polar pivot (+ ang a (angle pivot data)) dis)
                 )
               )
             )
           )
         )
         (list p+ p-) (list 0 pi)
       )
       (grdraw (trans pivot 0 1) (cadr gr) -1)
     )
   )
 )
 (redraw) (princ)
)

(defun 2DPoint ( p ) (list (car p) (cadr p)))

(defun LM:SafearrayVariant ( datatype data )
 ;; © Lee Mac 2010
 (vlax-make-variant
   (vlax-safearray-fill
     (vlax-make-safearray datatype
       (cons 0 (1- (length data)))
     )
     data
   )    
 )
)

(defun LM:PointVariant ( lst )
 ;; © Lee Mac 2010
 (LM:SafearrayVariant vlax-VBDouble (apply 'append lst))
)

[Lee Mac]

Actually, this might be better:

 

(defun c:PolarStretch ( / sel p- p+ ang pt d1 d2 obj data gr )
 ;; © Lee Mac 2010
 (vl-load-com)

 (if (and (setq pt  (getpoint "\nSelect BasePoint; "))
          (setq ent (car (nentselp pt)))
          (eq "LWPOLYLINE" (cdr (assoc 0 (entget ent)))))
   (progn
     (setq p- (fix (vlax-curve-getParamatPoint ent
                     (vlax-curve-getClosestPointto ent pt))) p+ (1+ p-))

     (setq ang (angle pt (vlax-curve-getPointatParam ent p+))
           d1  (distance pt (vlax-curve-getPointatParam ent p-))
           d2  (distance pt (vlax-curve-getPointatParam ent p+)))

     (setq obj (vlax-ename->vla-object ent))

     (while (= 5 (car (setq gr (grread 't 13 0)))) (redraw)
       (setq data (trans (cadr gr) 1 0))

       (mapcar
        '(lambda ( parameter a d )
           (vla-put-Coordinate obj parameter
             (LM:PointVariant
               (list
                 (2DPoint
                   (polar pt (+ ang a (angle pt data)) d)
                 )
               )
             )
           )
         )
         (list p- p+) (list pi 0) (list d1 d2)
       )
       (grdraw (trans pt 0 1) (cadr gr) -1)
     )
   )
 )
 (redraw) (princ)
)

(defun 2DPoint ( p ) (list (car p) (cadr p)))

(defun LM:SafearrayVariant ( datatype data )
 ;; © Lee Mac 2010
 (vlax-make-variant
   (vlax-safearray-fill
     (vlax-make-safearray datatype
       (cons 0 (1- (length data)))
     )
     data
   )    
 )
)

(defun LM:PointVariant ( lst )
 ;; © Lee Mac 2010
 (LM:SafearrayVariant vlax-VBDouble (apply 'append lst))
)

 

Neither will support OSnap/Ortho etc, just an academic exercise.

[Shahin]

Thanks Lee. it is close to what i am looking for. However, I need to make a crossing window selection and rotate everything in it at the same time. I my real case, there are number of objects it is nearly impossible to do it one by one.

Thanks again.

 

Shahin

[Bill2]

Shahin, see if this works for you.

-Bill

;This will stretch polar by a distance in inches
;1st-widow select
;2nd-click on the line you want to have follow the "stretch amount"
;3rd-enter the distance you want to stretch
;by-Bill Kohrman

(defun c:SR (/ cmd sslines lineref sdist radi centi pnti pickang p1ang p2ang angdifp1 angdifp2 refang Radang Aangi cnt tname entpnt tpnt tang tangdifref tangdif1 Rangi)
(vl-load-com)

(defun *error* ( msg )
    (setvar "cmdecho" cmd)
    (setvar "ERRNO" 0)
    (princ "error: ")
    (princ msg)
    (princ)
)

(vla-StartUndoMark (setq actDoc (vla-get-ActiveDocument (vlax-get-acad-object))))
(setq cmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setvar "ERRNO" 0)

(setq sslines (ssget))
(while (and (/= (getvar "ERRNO") 52)(= lineref nil))
    (setq lineref (entsel "\nSelect Reference Line at Desired Stretch End: "))
)
(setq sdist (getreal "\nEnter Stretch Distance: "))
(setq radi (cdr (assoc 40 (entget  (car lineref)))))
(setq centi (cdr (assoc 10 (entget (car lineref)))))
(setq pnti (cadr lineref))
(setq pickang (angle centi pnti))
(setq p1ang (cdr (assoc 50 (entget (car lineref)))))
(setq p2ang (cdr (assoc 51 (entget (car lineref)))))

(setq angdifp1 (abs (- p1ang pickang)))
(setq angdifp2 (abs (- p2ang pickang)))
(if (> angdifp1 angdifp2)
    (setq refang p1ang)
    (setq refang p2ang)
)
(setq Radang (/ sdist radi))
(setq Aangi (* Radang (/ 180.0 pi)))

(repeat (setq cnt (sslength sslines))
    (if (= (cdr (assoc 0 (entget (setq tname (ssname sslines (setq cnt (- cnt 1))))))) "ARC")
        (progn
            (setq entpnt (list tname pnti))
            (command "lengthen" "de" "a" Aangi entpnt "")
        )
        (progn
            (setq tpnt (cdr (assoc 10 (entget tname))))
            (setq tang (angle centi tpnt))
            (setq tangdifref (abs (- refang tang)))
            (setq tangdif1 (abs (- refang (+ tang Radang))))            
            (cond
                ((and (> tangdif1 tangdifref)(> (- p2ang p1ang) 0.0))
                    (setq Rangi Aangi)
                )
                ((and (< tangdif1 tangdifref)(> (- p2ang p1ang) 0.0))
                    (setq Rangi (* Aangi -1.0))
                )
                ((and (> tangdif1 tangdifref)(< (- p2ang p1ang) 0.0))
                    (setq Rangi (* Aangi -1.0))
                )
                ((and (< tangdif1 tangdifref)(< (- p2ang p1ang) 0.0))
                    (setq Rangi Aangi)
                )
            )
            (if (> sdist 0.0)
                (princ)
                (setq Rangi (* Rangi -1.0))
            )    
            (command "rotate" tname "" centi Rangi)
        )
    )
)

(setvar "cmdecho" cmd)
(vla-EndUndoMark actDoc)
(princ "\nProgram Finished")
(princ)
)

 

Edited July 12, 2020 by CADTutor
Moved code to code block