TheSwamp

Code Red => AutoLISP (Vanilla / Visual) => Topic started by: Hugo on January 02, 2012, 05:05:20 AM

Title: Copy and rotate (kopieren und drehen)
Post by: Hugo on January 02, 2012, 05:05:20 AM
Can I make it better
Thank you

Kann man das besser machen
Danke

Code: [Select]
(defun c:copydreh ()
        (setvar "cmdecho" 0)
  (while(setq el (car (entsel)))
        (setq el1 (entget el))
        (setq p1 (cdr (assoc 10 el1)))
        (command "_copy" (ssadd el) "" p1 pause)
        (setq en (entget(entlast)))
        (princ "\nPress [Tab] to Rotate Text <Accept>: ")
       (while (= 9 (cadr (grread nil 2)));;(while (= 9 (cadr (grread nil 2)))
          (setq rt(assoc 50 en)
                en(entmod (subst (cons 50 (rem (+ (/ pi 2.) (cdr rt)) (+ pi pi))) rt en))
          )
       );while
        (setvar "cmdecho" 1)
  );while
);defun
Title: Re: Copy and rotate (kopieren und drehen)
Post by: pBe on January 02, 2012, 07:13:14 AM
Code: [Select]
(defun c:copydreh ()
        (setvar "cmdecho" 0)
  (while(setq el (car (entsel)))
        (setq el1 (entget el))
        (setq p1 (cdr (assoc 10 el1)))
        (command "_copy" (ssadd el) "" (trans p1 0 1) pause)
        ;(setq en (entget (entlast)))
    (setq en (vlax-ename->vla-object (entlast)))
        (princ "\nPress [Tab] to Rotate Text <Accept>: ")
       (while (= 9 (cadr (grread nil 2)));;(while (= 9 (cadr (grread nil 2)))
          (setq rt (vla-get-rotation en))
             ;   en
             ;(entmod (subst (cons 50 (rem (+ (/ pi 2.) (cdr rt)) (+ pi pi))) rt en))
              (vla-put-rotation en (rem (+ (/ pi 2.) rt) (+ pi pi)) )
          ;)
       );while
        (setvar "cmdecho" 1)
  );while
)

Trans <---- UCS Issues
vla-put-rotation <----More Annotative Text/Mtext Friendly  :-D
Title: Re: Copy and rotate (kopieren und drehen)
Post by: DEVITG on January 02, 2012, 07:50:48 AM
What about  Express tool MOCORO?
Title: Re: Copy and rotate (kopieren und drehen)
Post by: Hugo on January 02, 2012, 08:20:00 AM
@ pBe

Thank you
even better would be before turning and then copy

noch besser wäre vorher drehen und dann kopieren
Danke

@Devitg

with Mocoron I'm not as fast
mit Mocoro bin ich nicht so schnell

Title: Re: Copy and rotate (kopieren und drehen)
Post by: Tharwat on January 02, 2012, 08:33:54 AM
Localizing variables and filtration of selection sets would be much more better to avoid any error or crash of codes  :wink:
Title: Re: Copy and rotate (kopieren und drehen)
Post by: Hugo on January 02, 2012, 09:54:44 AM
@Tharwat

Yes, thank you
Ja danke
Title: Re: Copy and rotate (kopieren und drehen)
Post by: CAB on January 05, 2012, 11:59:32 AM
Here is one of my old routine that may be of interest to you.
Code: [Select]
;;;  CopyRotate.lsp by Charles Alan Butler
;;;         Copyright 2008
;;;  by Precision Drafting & Design All Rights Reserved.
;;;  Contact at TheSwamp.org
;;;
;;;   Version 5.2  Sep 04, 2008
;;;
;;; DESCRIPTION
;;; User pick base point then selects object(s)
;;; Paste mode until Escape is pressed
;;; Once placed user selects rotation angle
;;;
;;; Command Line Usage
;;; Command: copyr
;;;;;  Copy objects, then paste & rotate new copy
(defun c:copyr (/ pt npt ss elast ssnew ale_lastent ale_ss-after *error*
                MoveStarted osmodetmp usrosmode)

  (princ "\nVwerion 5 CopyR lisp")
 
  ;; error function & Routine Exit
  (defun *error* (msg)
    (if
      (not
        (member
            msg
           '("console break" "Function cancelled" "quit / exit abort" "")
        )
      )
       (princ (strcat "\nError: " msg))
    ) ; endif
    (and usrosmode (setvar "osmode" usrosmode))
    (and usrormode (setvar "orthomode" usrormode))
    (if (and MoveStarted ssnew)
      (command "._erase" ssnew "")
    )
   )
  ;; Rune Wold and Michael Puckett - modified ale_lastent ale_ss-after
  (defun ale_lastent (/ entnam outval)
    (and
      (setq outval (entlast))
      (while (setq entnam (entnext outval))
        (setq outval entnam)
      )
    )
    outval
  )

  (defun ale_ss-after (entnam / entnxt selset)
    (cond
      ((not entnam) (ssget "_X"))
      ((setq entnxt (entnext entnam))
       (setq selset (ssadd entnxt))
       (while (setq entnxt (entnext entnxt))
         (if (entget entnxt)
           (ssadd entnxt selset)
         )
       )
       selset
      )
    )
  )

 
  (setq usrosmode (getvar "osmode")) ; reset when routine ends
  (setq usroRmode (getvar "orthomode")) ; reset when routine ends
  (setq osmodetmp (getvar "osmode")) ; temp setting
  (setq ormodetmp (getvar "orthomode")) ; temp setting
  (if (and (null (prompt "\nSelect objects to copy:"))
           (setq ss (ssget))
           (setq pt (getpoint "\nPick base point:"))
      )
    (progn
      (setvar "osmode" 0)
      (command "._copybase" pt ss "") ; get object(s) to copy
      (command "._undo" "_begin")
      (setq elast (ale_lastent))
      (command "._pasteclip" pt) ; Create a Copy in the drawing, then move it
      (setq ssnew (ale_ss-after elast))
      (while
        (progn
          (setq MoveStarted t)
  (setvar "osmode" 0)
  (setvar "orthomode" 0)
          (command "._move" ssnew ""  pt)
          ;;(setvar "osmode" osmodetmp)
          (command pause)
          (if (or (and (null npt) (setq npt (getvar "lastpoint")))
                  (> (distance pt (setq npt (getvar "lastpoint"))) 0.0001))
            (progn
              ;;  allow user to rotate
              (setvar "osmode" osmodetmp)
              (setvar "orthomode" 1)
              (command "._rotate" ssnew "" "_non" npt)
              (command pause)
              (setq MoveStarted nil)
              (setq osmodetmp (getvar "osmode"))
              (command "._undo" "_end")
              (command "._undo" "_begin")
              ;;  get last item in database
              (setq elast (ale_lastent))
      (setvar "osmode" 0)
              (command "._pasteclip" pt)
              ;;  get new items pasted.
              (setq ssnew (ale_ss-after elast))
              t ; stay in loop
            )
          )
        )
      ) ; while
    ) ; progn
  ) ; endif
  (*error* "")
  (command "._undo" "_end")
  (princ)
)
(princ)
Title: Re: Copy and rotate (kopieren und drehen)
Post by: BlackBox on January 05, 2012, 12:24:29 PM
This needs some updating, but here's one written a while back that uses the acet-ss-drag-move function:

Code: [Select]
(defun c:CORO () (c:CopyRotate))
(defun c:CopyRotate  (/ *error* ss p1 p2)
  (princ "\rCOPYROTATE ")

  (defun *error*  (msg)
    (if flag
      (command "._erase" ss2 ""))
    (and oldCmdecho (setvar 'cmdecho oldCmdecho))
    (and oldMenuecho (setvar 'menuecho oldMenuecho))
    (and oldNomutt (setvar 'nomutt oldNomutt))
    (cond ((not msg))                                                   ; Normal exit
          ((member msg '("Function cancelled" "quit / exit abort")))    ; <esc> or (quit)
          ((princ (strcat "\n** Error: " msg " ** "))))                 ; Fatal error, display it
    (princ))

  ((lambda (oldCmdecho oldMenuecho oldNomutt e flag ss2)
     (prompt "\nSelect object(s) to copy rotate: ")
     (if (and (setq ss (ssget "_:L"))
              (setq p1 (getpoint "\nSpecify base point: "))
              (setq p2 (acet-ss-drag-move
                         ss
                         p1
                         "\nLocate new object(s): "
                         T)))
       (progn
         (prompt "\nEnter rotation angle: ")
         (setvar 'cmdecho 0)
         (setvar 'menuecho 6)
         (setvar 'nomutt 1)
         (command "._copy" ss "" "_non" p1 "_non" p2)
         (while (/= nil (setq e (entnext e))) (ssadd e ss2))
         (command "._rotate" ss2 "" p2)
         (setq flag nil)))
     (*error* nil))
    (getvar 'cmdecho)
    (getvar 'menuecho)
    (getvar 'nomutt)
    (entlast)
    T
    (ssadd)))
Title: Re: Copy and rotate (kopieren und drehen)
Post by: Lee Mac on January 05, 2012, 12:33:09 PM
Another,

Code: [Select]
(defun c:cr ( / s )
    (if (setq s (ssget "_:L")) (command "_.rotate" s "" pause "_C" pause))
    (princ)
)
Title: Re: Copy and rotate (kopieren und drehen)
Post by: BlackBox on January 05, 2012, 12:57:25 PM
Sure, if you like to copy/rotate in place.  :-P

Edit - more accurately, about the base point. The others allow for direct placement is all.
Title: Re: Copy and rotate (kopieren und drehen)
Post by: BlackBox on January 05, 2012, 01:05:19 PM
Streamlined version of my earlier post (removed the system variable changes, and error handling):

Code: [Select]
(defun c:CORO  (/ e ss p1 p2 ss2)
  (setq e (entlast))
  (if (and (setq ss (ssget "_:L"))
           (setq p1 (getpoint "\nSpecify base point: "))
           (setq p2 (acet-ss-drag-move
                      ss
                      p1
                      "\nLocate new object(s): "
                      T))
           (setq ss2 (ssadd)))
    (progn
      (command "._copy" ss "" "_non" p1 "_non" p2)
      (while (/= nil (setq e (entnext e))) (ssadd e ss2))
      (command "._rotate" ss2 "" p2)))
  (princ))
Title: Re: Copy and rotate (kopieren und drehen)
Post by: Lee Mac on January 05, 2012, 01:17:59 PM
Streamlined version of my earlier post (removed the system variable changes, and error handling):

Watch out for when 'entlast' is an attributed block, or 3D Polyline; and also for the setting of COPYMODE.  :wink:

As a simple command call version, I would suggest perhaps:

Code: [Select]
(defun c:cr ( / c s )
    (if (setq c (getvar 'COPYMODE)) (setvar 'COPYMODE 1))
    (if (setq s (ssget "_:L"))
        (command
            "_.copy"   s "" "_non" '(0 0 0) "_non" "@"
            "_.move"   s "" pause pause
            "_.rotate" s "" "_non" (getvar 'LASTPOINT) pause
        )
    )
    (if c (setvar 'COPYMODE c))
    (princ)
)

<< Edit, added extra "_non" >>
Title: Re: Copy and rotate (kopieren und drehen)
Post by: BlackBox on January 05, 2012, 01:22:42 PM
Watch out for when 'entlast' is an attributed block, or 3D Polyline; and also for the setting of COPYMODE.  :wink:

*Touches finger to tip of nose*

*Points finger at Lee*

(https://encrypted-tbn3.google.com/images?q=tbn:ANd9GcRdfOyDnss7gLAOyfxJglqwWzcvJpuNPBluPGKg3qQ1bQh2YKHMJg)
Title: Re: Copy and rotate (kopieren und drehen)
Post by: alanjt on January 05, 2012, 01:51:29 PM
Code: [Select]
(defun c:CAR (/ *error* ss p1 p2 add temp lst ang)

  (vl-load-com)

  (defun *error* (msg)
    (and *AcadDoc* (vla-endundomark *AcadDoc*))
    (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,")))
      (princ (strcat "\nError: " msg))
    )
  )

  (vla-startundomark
    (cond (*AcadDoc*)
          ((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
    )
  )

  (if (and (setq ss (ssget "_:L"))
           (setq p1 (getpoint "\nSpecify base point: "))
           (setq p2 (acet-ss-drag-move ss p1 "\nSpecify second point: " T))
           (progn (setq add (ssadd)
                        p1  (trans p1 1 0)
                        p2  (trans p2 1 0)
                  )
                  (vlax-for x (setq ss (vla-get-activeselectionset *AcadDoc*))
                    (vlax-invoke (setq temp (vla-copy x)) 'move p1 p2)
                    (ssadd (vlax-vla-object->ename temp) add)
                    (setq lst (cons temp lst))
                  )
                  (vla-delete ss)
                  T
           )
           (setq ang (acet-ss-drag-rotate add (trans p2 0 1) T))
      )
    (foreach x lst (vlax-invoke x 'rotate p2 ang))
  )

  (*error* nil)
  (princ)
)
Title: Re: Copy and rotate (kopieren und drehen)
Post by: BlackBox on January 05, 2012, 02:10:24 PM
Nice usage of acet-ss-drag-rotate, Alan. :beer:

I really need to go over the acet* functions again. LoL
Title: Re: Copy and rotate (kopieren und drehen)
Post by: alanjt on January 05, 2012, 03:14:37 PM
Nice usage of acet-ss-drag-rotate, Alan. :beer:

I really need to go over the acet* functions again. LoL
:)
There's also acet-ss-drag-scale.
Title: Re: Copy and rotate (kopieren und drehen)
Post by: BlackBox on January 05, 2012, 03:20:50 PM
For those who are interested:

acet-ss-drag-move
Quote

(acet-ss-drag-move ss pt [prompt] [highlight [cursor]])

Drag a selection set to change location.

Arguments
ss: The selection set to drag.
pt: The base point.
prompt: A message to display before dragging is started.
highlight: If given, causes a rubber-band line to be drawn from pt to the current cursor position while dragging; this parameter can be nil to draw a rubber-band line in the inverse of the screen color, or non-nil to draw a highlighted line.
cursor: The cursor form to display while dragging (0=crosshairs, 1=no cursor, 2=target).

Return Values
Normally returns the selected point, but will honor initget settings and can return arbitrary text or keywords. Returns nil if the dragging operation is aborted.

Note:
The acet-ss-drag-move function does not move the selection set, but allows selection of a new position while showing how the result will appear.

acet-ss-drag-rotate
Quote

(acet-ss-drag-rotate ss pt [prompt] [highlight [cursor]])

Drag a selection set to change rotation.

Arguments
ss: The selection set to drag.
pt: The base point.
prompt: A message to display before dragging is started.
highlight: If given, causes a rubber-band line to be drawn from pt to the current cursor position while dragging; this parameter can be nil to draw a rubber-band line in the inverse of the screen color, or non-nil to draw a highlighted line.
cursor: Gives the cursor form to display while dragging (0=crosshairs, 1=no cursor, 2=target).

Return Values
The selected rotation value, or nil if dragging is aborted.

Note:
The acet-ss-drag-rotate function does not rotate the selection set, but allows selection of a rotation value while showing how the result will appear.

acet-ss-drag-scale
Quote

(acet-ss-drag-scale ss pt [prompt] [highlight [cursor]])

Drag a selection set to change scale.

Arguments
ss: The selection set to drag.
pt: The base point.
prompt: A message to display before dragging is started.
highlight: If given, causes a rubber-band line to be drawn from pt to the current cursor position while dragging; this parameter can be nil to draw a rubber-band line in the inverse of the screen color, or non-nil to draw a highlighted line.
cursor: Gives the cursor form to display while dragging (0=crosshairs, 1=no cursor, 2=target).

Return Values
The selected scale factor, or nil if dragging is aborted.

Note:
The acet-ss-drag-scale function does not scale the selection set, but allows selection of a scaling factor while showing how the result will appear.
Title: Re: Copy and rotate (kopieren und drehen)
Post by: alanjt on January 05, 2012, 03:25:01 PM
(http://www.theswamp.org/lilly_pond/alanjt/cough.gif)
Title: Re: Copy and rotate (kopieren und drehen)
Post by: BlackBox on January 05, 2012, 03:25:49 PM
(http://www.theswamp.org/lilly_pond/alanjt/cough.gif)

LoL - That's where I got those from, silly.  :lol:

Edit - I wasn't sure if you'd mind my sharing the doc, so I posted the discussed functions only.
Title: Re: Copy and rotate (kopieren und drehen)
Post by: alanjt on January 05, 2012, 03:31:09 PM
(http://www.theswamp.org/lilly_pond/alanjt/cough.gif)

LoL - That's where I got those from, silly.  :lol:

Edit - I wasn't sure if you'd mind my sharing the doc, so I posted the discussed functions only.
Oops.
I didn't write the doc - found online when I started LISP'n.
Title: Re: Copy and rotate (kopieren und drehen)
Post by: BlackBox on January 05, 2012, 04:24:28 PM
(http://www.theswamp.org/lilly_pond/alanjt/cough.gif)

LoL - That's where I got those from, silly.  :lol:

Edit - I wasn't sure if you'd mind my sharing the doc, so I posted the discussed functions only.
Oops.
I didn't write the doc - found online when I started LISP'n.
:lmao:
Title: Re: Copy and rotate (kopieren und drehen)
Post by: Hugo on January 06, 2012, 05:04:16 AM
@ Lee

Have the Lisp CHANGED to accurately align the objects again.
Is this ok Sun
Thank you

Habe das Lisp geänder um die Objekte nochmal genau auszurichten.
Ist das ok so.
Danke

Code: [Select]
(defun c:cr ( / c s )
    (if (setq c (getvar 'COPYMODE)) (setvar 'COPYMODE 1))
    (if (setq s (ssget "_:L"))
        (command
            "_.copy"   s "" "_non" '(0 0 0) "_non" "@"
            "_.move"   s "" pause pause
            "_.rotate" s "" "_non" (getvar 'LASTPOINT) pause
            "_.move"   s "" (getvar 'LASTPOINT)
        )
    )
    (if c (setvar 'COPYMODE c))
    (princ)
)
Title: Re: Copy and rotate (kopieren und drehen)
Post by: Lee Mac on January 06, 2012, 06:51:22 AM
Sorry Hugo, I'm not sure that I understand?
Title: Re: Copy and rotate (kopieren und drehen)
Post by: Hugo on January 06, 2012, 07:37:04 AM
I've added the move
is it ok

ich habe Schieben hinzugefügt
ist das ok
Title: Re: Copy and rotate (kopieren und drehen)
Post by: Hugo on January 08, 2012, 04:21:41 AM
Thanks to all   :-)

Danke an alle
Title: Re: Copy and rotate (kopieren und drehen)
Post by: ribarm on September 19, 2012, 04:00:03 AM
Hugo, you were probably looking for this to imitate MOCORO - faster solution :

Code: [Select]
(defun c:cr ( / *error* c s )
  (defun *error* (msg)
    (if c (setvar 'COPYMODE c))
    (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,")))
      (princ (strcat "\nError: " msg))
    )
  )
  (if (setq c (getvar 'COPYMODE)) (setvar 'COPYMODE 1))
  (defun cr nil
    (if (not (eq s nil))
      (progn
        (command
            "_.copy"   s "" "_non" '(0 0 0) "_non" "@"
            "_.move"   s "" pause pause
            "_.rotate" s "" "_non" (getvar 'LASTPOINT) pause
            "_.move"   s "" (getvar 'LASTPOINT) pause
        )
        (cr)
      )
      (progn
        (setq s (ssget "_:L"))
        (command
            "_.copy"   s "" "_non" '(0 0 0) "_non" "@"
            "_.move"   s "" pause pause
            "_.rotate" s "" "_non" (getvar 'LASTPOINT) pause
            "_.move"   s "" (getvar 'LASTPOINT) pause
        )
        (cr)
      )
    )
  )
  (cr)
  (*error* nil)
  (princ)
)

(defun c:mr ( / s )
  (defun mr nil
    (if (not (eq s nil))
      (progn
        (command
            "_.move"   s "" pause pause
            "_.rotate" s "" "_non" (getvar 'LASTPOINT) pause
        )
        (mr)
      )
      (progn
        (setq s (ssget "_:L"))
        (command
            "_.move"   s "" pause pause
            "_.rotate" s "" "_non" (getvar 'LASTPOINT) pause
        )
        (mr)
      )
    )
  )
  (mr)
  (princ)
)

M.R.
Title: Re: Copy and rotate (kopieren und drehen)
Post by: Hugo on September 19, 2012, 04:26:23 AM
super Thanks    :-)

super Danke
Title: Re: Copy and rotate (kopieren und drehen)
Post by: ribarm on September 19, 2012, 05:07:25 AM
You're welcome Hugo, just added error handler, because of sysvar COPYMODE... Now it should work correct - to finish press ESC - terminate routine...

M.R. :-)
Title: Re: Copy and rotate (kopieren und drehen)
Post by: Hugo on September 19, 2012, 07:03:32 AM
Danke  :-) :-)
Title: Re: Copy and rotate (kopieren und drehen)
Post by: ribarm on September 21, 2012, 04:41:59 AM
Modified further more - maybe this version is more adequate - we don't know if we want copy, move or rotate, so I leaved all options open - only thing is that you have to do things with keyboard also... I couldn't think anything better than this - it uses grread :

Code - Auto/Visual Lisp: [Select]
  1. (defun c:mcr ( / *error* c cmde s )
  2.   (defun *error* (msg)
  3.     (if c (setvar 'COPYMODE c))
  4.     (if cmde (setvar 'CMDECHO cmde))
  5.     (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,")))
  6.       (princ (strcat "\nError: " msg))
  7.     )
  8.   )
  9.   (if (setq cmde (getvar 'CMDECHO)) (setvar 'CMDECHO 0))
  10.   (if (setq c (getvar 'COPYMODE)) (setvar 'COPYMODE 1))
  11.   (defun do_C nil
  12.     (prompt "\nNext point : ")
  13.     (command "_.point" "_non" "@")
  14.     (setq l (cons (trans (cdr (assoc 10 (entget (entlast)))) 0 1) l))
  15.     (entdel (entlast))
  16.     (command "_.undo" "m")
  17.     (command "_.copy" s "" "_non" (getvar 'LASTPOINT) "_non" (getvar 'LASTPOINT))
  18.     (command "_.move" s "" "_non" (if llp (setq lp llp) (setq lp (getvar 'LASTPOINT))) pause)
  19.     (setq lllp (mapcar '- (setq llp (getvar 'LASTPOINT)) lp))
  20.   )
  21.   (defun do_CC nil
  22.     (command "_.point" "_non" "@")
  23.     (setq l (cons (trans (cdr (assoc 10 (entget (entlast)))) 0 1) l))
  24.     (entdel (entlast))
  25.     (command "_.undo" "m")
  26.     (command "_.copy" s "" "_non" (getvar 'LASTPOINT) "_non" (getvar 'LASTPOINT))
  27.     (command "_.move" s "" "_non" (if llp llp (setq lp (getvar 'LASTPOINT))) "_non" (if llp (setq llp (mapcar '+ llp lllp)) lp))
  28.   )
  29.   (defun do_CCC ( / n k kk pt )
  30.     (command "_.point" "_non" "@")
  31.     (setq l (cons (trans (cdr (assoc 10 (entget (entlast)))) 0 1) l))
  32.     (entdel (entlast))
  33.     (command "_.undo" "m")
  34.     (initget 7)
  35.     (setq n (getint "\nEnter number of array items - (spaces - 1) : "))
  36.     (command "_.copy" s "" "_non" (getvar 'LASTPOINT) "_non" (getvar 'LASTPOINT))
  37.     (command "_.move" s "" "_non" (if llp (setq lp llp) (setq lp (getvar 'LASTPOINT))) pause)
  38.     (setq lllp (mapcar '- (setq llp (getvar 'LASTPOINT)) lp))
  39.     (setq k (float (+ n 1)))
  40.     (setq kk 0.0)
  41.     (repeat n
  42.       (setq pt (mapcar '- lp (mapcar '* (list (* (setq kk (1+ kk)) (/ 1.0 k)) (* kk (/ 1.0 k)) (* kk (/ 1.0 k))) lllp)))
  43.       (command "_.copy" s "" "_non" lp "_non" pt)
  44.     )
  45.     (setvar 'LASTPOINT llp)
  46.   )
  47.   (defun do_M nil
  48.     (prompt "\nNext point : ")
  49.     (command "_.point" "_non" "@")
  50.     (setq l (cons (trans (cdr (assoc 10 (entget (entlast)))) 0 1) l))
  51.     (entdel (entlast))
  52.     (command "_.undo" "m")
  53.     (command "_.move" s "" "_non" (if llp (setq lp llp) (setq lp (getvar 'LASTPOINT))) pause)
  54.     (setq lllp (mapcar '- (setq llp (getvar 'LASTPOINT)) lp))
  55.   )
  56.   (defun do_MM nil
  57.     (command "_.point" "_non" "@")
  58.     (setq l (cons (trans (cdr (assoc 10 (entget (entlast)))) 0 1) l))
  59.     (entdel (entlast))
  60.     (command "_.undo" "m")
  61.     (command "_.move" s "" "_non" (if llp llp (setq lp (getvar 'LASTPOINT))) "_non" (if llp (setq llp (mapcar '+ llp lllp)) lp))
  62.     )
  63.   (defun do_R nil
  64.     (prompt "\nAngle in decimal degrees : ")
  65.     (command "_.point" "_non" "@")
  66.     (setq l (cons (trans (cdr (assoc 10 (entget (entlast)))) 0 1) l))
  67.     (entdel (entlast))
  68.     (command "_.undo" "m")
  69.     (command "_.rotate" s "" "_non" (if llp llp (getvar 'LASTPOINT)) pause)
  70.   )
  71.   (defun do_RT nil
  72.     (command "_.point" "_non" "@")
  73.     (setq l (cons (trans (cdr (assoc 10 (entget (entlast)))) 0 1) l))
  74.     (entdel (entlast))
  75.     (command "_.undo" "m")
  76.     (command "_.rotate" s "" "_non" (if llp llp (getvar 'LASTPOINT)) 90)
  77.   )
  78.   (defun do_RR nil
  79.     (command "_.point" "_non" "@")
  80.     (setq l (cons (trans (cdr (assoc 10 (entget (entlast)))) 0 1) l))
  81.     (entdel (entlast))
  82.     (command "_.undo" "m")
  83.     (command "_.rotate" s "" "_non" (if llp llp (getvar 'LASTPOINT)) "")
  84.   )
  85.   (defun do_U nil
  86.     (command "_.undo" "b")
  87.     (setq llp (car l))
  88.     (setvar 'LASTPOINT llp)
  89.     (setq l (cdr l))
  90.   )
  91.   (defun mcr ( / loop gr l p lp llp lllp )
  92.     (setq loop T)
  93.     (if (not (eq s nil))
  94.       (while loop
  95.         (prompt "\n\"S\" key for new selection and basepoint; \"P\" key for base point; \t\"C\" key for copy; \"A\" key for copy-array; \"D\" key for copy-continuous; \"M\" key for move; \"N\" key for move-continuous; \t\"R\" key for rotate; \"T\" key for rotate-again; \"TAB\" key for rotate by 90 degree; \"U\" key for undo; ESC, right mouse click to end")
  96.         (setq gr (grread nil 14 0))
  97.         (cond
  98.           ((or (equal gr '(2 115)) (equal gr '(2 83))) (progn (setq s nil) (mcr)))
  99.           ((or (equal gr '(2 112)) (equal gr '(2 80))) (progn (setq p (getpoint "\nPick base point : ")) (setq llp nil) (setvar 'LASTPOINT p)))
  100.           ((or (equal gr '(2 99)) (equal gr '(2 67))) (do_C))
  101.           ((or (equal gr '(2 100)) (equal gr '(2 68))) (do_CC))
  102.           ((or (equal gr '(2 97)) (equal gr '(2 65))) (do_CCC))
  103.           ((or (equal gr '(2 109)) (equal gr '(2 77))) (do_M))
  104.           ((or (equal gr '(2 110)) (equal gr '(2 78))) (do_MM))
  105.           ((or (equal gr '(2 114)) (equal gr '(2 82))) (do_R))
  106.           ((or (equal gr '(2 116)) (equal gr '(2 84))) (do_RR))
  107.           ((or (equal gr '(2 117)) (equal gr '(2 85))) (do_U))
  108.           ((equal gr '(2 9)) (do_RT))
  109.           ((or (equal gr '(2 27)) (eq (car gr) 11) (eq (car gr) 25)) (setq loop nil))
  110.         )
  111.       )
  112.       (progn
  113.         (setq s (ssget "_:L"))
  114.         (setq p (getpoint "\nPick base point : "))
  115.         (setvar 'LASTPOINT p)
  116.         (mcr)
  117.       )
  118.     )
  119.   )
  120.   (mcr)
  121.   (*error* nil)
  122.   (princ)
  123. )
  124.  

And you're welcome Hugo, regards, M.R. :wink:
Title: Re: Copy and rotate (kopieren und drehen)
Post by: Hugo on September 21, 2012, 06:39:04 AM
Super Thank you   :-) :-)

Super Danke
Title: Re: Copy and rotate (kopieren und drehen)
Post by: ribarm on September 21, 2012, 07:09:16 AM
Little more modified - check my code again... Added option to change picked base point and new selection with its basepoint... If angle is already entered first time when using "R" option, you can repeat "R" and "SPACE" several times and it will rotate by incrementing in around circling that angle - useful if angle was 45 degree or 90 degree...

M.R.
Title: Re: Copy and rotate (kopieren und drehen)
Post by: Hugo on September 21, 2012, 10:15:39 AM
Super Thank you is always better    :-)

Title: Re: Copy and rotate (kopieren und drehen)
Post by: ribarm on September 21, 2012, 11:25:18 AM
Yes, I am always better... Further more modified - 2 more options added : copy-previous and move-previous... Very useful... Check it now, I think that's all from me - also changed name : c:mcr...

Regards, M.R.
 8-)
Title: Re: Copy and rotate (kopieren und drehen)
Post by: Hugo on September 21, 2012, 01:12:59 PM
real tool

What would be great if you could use the TAB key to make a 90-degree rotation.
Whenever I press the Tab key made ​​a 90-degree rotation.

Thank you
If it continues

Echt tool

Was toll wäre wenn man die TAB Taste verwenden könnte um ein Drehung um 90 Grad zu machen.
Immer wenn ich die Tab Taste drücke wird einen Drehung um 90 Grad gemacht.

Danke
Wenn das geht
Title: Re: Copy and rotate (kopieren und drehen)
Post by: ribarm on September 21, 2012, 02:06:56 PM
Done as you wished Hugo, TAB - rotate by 90 degree... I'll attach *.lsp - there were minor bugs, but now it's all OK - checked once again...

M.R.
Title: Re: Copy and rotate (kopieren und drehen)
Post by: Hugo on September 22, 2012, 02:39:45 AM
Thank you so much   :-) :-) :-)

Vielen vielen Dank

One more question would go something like also like to film with slide and copy.
Eine Frage noch würde sowas auch gehn wie auf Film mit Schieben und kopieren.
Title: Re: Copy and rotate (kopieren und drehen)
Post by: ribarm on September 22, 2012, 05:00:45 AM
Hugo, my Camtasia Studio isn't functioning well, you'll have to ask someone with more experience in capturing video than me to capture how my function works... From what you posted it looks like the same but little different routine - with my you have to perform first "M" move, than rotate by 90 "TAB" several times, then again "M" move and even more you have to firstly select object(s) and pick base point... But nevertheless, my have additional options for copy-previous and move-previous...

I am sure that here at www.theswamp.org, there are plenty of people that can do capturing with small size animated *.gif or some other file format that can be posted on the site...

Have a nice day, Hugo...
Ich wunche dir gutten Tag, Hugo...
Tschus, M.R.
Title: Re: Copy and rotate (kopieren und drehen)
Post by: ribarm on September 23, 2012, 01:32:36 AM
Improved further more... New options are : rotate by the same angle again - key "T" and undo option - key "U" - very useful when you made mistake and if you want to return to start angle - simply I haven't found anywhere on the www how to remember negative value of previously input angle when rotated, so I decided to implement "U" undo...

Regards, M.R.
 :-)
Title: Re: Copy and rotate (kopieren und drehen)
Post by: Hugo on September 23, 2012, 04:32:27 AM
Super Thank you

Would be a better SWF Video

here again in mp4

Super Danke

Wäre ein SWF Video besser
Title: Re: Copy and rotate (kopieren und drehen)
Post by: ribarm on September 23, 2012, 07:04:40 AM
So here is my final version of mcr.lsp - attached here... Revisions are made to undo process - added marks before each sequence, and when called undo it returns back for that step - notice that copy options had 2 steps (copy+move) so I had to mark them... Also notice that if you want to be kept in memory base point, you only have one undo step - if you do several undos it may mess base point so you'll have to input it again with "P" option - this doesn't matter if you undo several rotations as their base points are the same... Also note that you may undo everything while holding "U" key so be careful when doing this - think that it will ask - do you want to undo everything - if you type yes it will undo to the point where it was last saved...

Bye, M.R.
Tschus...
Title: Re: Copy and rotate (kopieren und drehen)
Post by: Hugo on September 23, 2012, 07:40:07 AM
Super Thank you
Title: Re: Copy and rotate (kopieren und drehen)
Post by: ribarm on September 23, 2012, 08:01:41 AM
Sorry Hugo, this is now mcr.lsp that's fine... It didn't wanted to undo after move several move sequences...

My apology,
M.R.
Title: Re: Copy and rotate (kopieren und drehen)
Post by: ribarm on September 23, 2012, 08:39:05 AM
Didn't see the same revision - only now is OK... I was blind :?

M.R.
Title: Re: Copy and rotate (kopieren und drehen)
Post by: Hugo on September 23, 2012, 09:52:43 AM
Thank you so many features I do not need copy and drehn drehn push and that's enough.

great Lisp


Danke so viele Funktionen brauche ich gar nicht copy und drehn schieben und drehn das reicht.

Tolles Lisp
Title: Re: Copy and rotate (kopieren und drehen)
Post by: ribarm on September 25, 2012, 12:44:14 AM
No need to redefine point with option "P" after multiple "U" undoes... LSP finally modified and attached here... So 7 downloads should update their codes with my code posted at the end of page 2 or re-download mcr.lsp from here...

There was 12 downloads before added copy-array option - now replaced attached mcr.lsp

T H E  E N D

M.R.
Title: Re: Copy and rotate (kopieren und drehen)
Post by: Hugo on September 25, 2012, 03:17:17 AM
super Thanks

Have changed these lines, I save a few clicks.
anyway since I just copy and move blocks and texts must.
Thanks again.

Code: [Select]
(setq s (car(entsel)));;(ssget "_:L"))
        (setq p (cdr(assoc 10 (entget s))));;(getpoint "\nPick base point : "))

super Danke 
Habe diese Zeilen geändert, spar ich mir ein paar klicks.
da ich sowieso nur blöcke und Texte kopieren und verschieben muss.
Danke nochmal.
Title: Re: Copy and rotate (kopieren und drehen)
Post by: ribarm on September 25, 2012, 06:29:05 AM
Hugo, you were probably working in WCS, so you didn't see how "U" undo option messes base points in some relative UCS... This is now also possible, just change UCS and you can work like you should - press few times undo and you can also continue from where you undo with normal actions...

My apology, I didn't saw it earlier, you have to download again... :mrgreen:
M.R.
Title: Re: Copy and rotate (kopieren und drehen)
Post by: Hugo on September 25, 2012, 06:59:05 AM
Yes I have tested works great
Thank you   :-) :-) :-)

Ja habe ich getestet funktioniert super
Danke
Title: Re: Copy and rotate (kopieren und drehen)
Post by: ribarm on October 06, 2012, 12:18:21 AM
Added one more option - "A" - copy-array (request by member from www.cadtutor.net)...

Regards, M.R.
c",)
(I saw this from pBe - nice trick with characters pBe) {8|O)
Title: Re: Copy and rotate (kopieren und drehen)
Post by: ribarm on October 06, 2012, 06:28:17 AM
There was some bug when using "U" undo option that I noticed only this morning - hope that now it's fixed... Please, report me if you find something strange (problem was with remembering base point after move sequence and undo sequence)...

Sincerely, M.R.
 :-)
Title: Re: Copy and rotate (kopieren und drehen)
Post by: ribarm on October 08, 2012, 09:43:19 AM
I've added new options for rotate-previous - "E" key and rotate-array - "Y" key, but as I didn't know how to obtain angle after rotate command I used trick with grread, so with these 2 options you have to be careful - input of rotation angles has to be made only with mouse picked point... In order to get rotate-previous, you have to use firstly "R" rotate option with mouse input and "Y" rotate-array you do it directly also with mouse input... Everything is noted in prompts when routine is running...

So until someone find out how to get rotation angle (to pass it into variable), this version with grread trick can do the job, only thing is I don't know how useful this is so it's strongly suggested that you keep also previously posted mcr.lsp

Now, here is new mcr-new.lsp

M.R.
Title: Re: Copy and rotate (kopieren und drehen)
Post by: ribarm on October 08, 2012, 02:18:25 PM
It seems that one more mouse click is necessary... So this is my final version - everything is prompted when routine is executed...

M.R.

c',}
Title: Re: Copy and rotate (kopieren und drehen)
Post by: ribarm on October 08, 2012, 04:22:05 PM
Sorry, I've noticed my mistake when undo after rotate-array - so I've added to remember selection set in undo... Now it's all OK...

Here is complete code :
Code - Auto/Visual Lisp: [Select]
  1. (defun c:mcr ( / *error* b c cmde s ang p l sss p1 p2 v ) ; l , sss - lexical globals
  2.   (defun *error* (msg)
  3.     (if b (setvar 'BLIPMODE b))
  4.     (if c (setvar 'COPYMODE c))
  5.     (if cmde (setvar 'CMDECHO cmde))
  6.     (if msg (prompt msg))
  7.     (princ)
  8.   )
  9.   (if (setq b (getvar 'BLIPMODE)) (setvar 'BLIPMODE 1))
  10.   (if (setq cmde (getvar 'CMDECHO)) (setvar 'CMDECHO 0))
  11.   (if (setq c (getvar 'COPYMODE)) (setvar 'COPYMODE 1))
  12.   (defun do_C nil
  13.     (prompt "\nNext point : ")
  14.     (vl-cmdf "_.point" "_non" (if l (car l) (getvar 'LASTPOINT)))
  15.     (setq l (cons (trans (cdr (assoc 10 (entget (entlast)))) 0 1) l))
  16.     (setq sss (cons s sss))
  17.     (entdel (entlast))
  18.     (vl-cmdf "_.undo" "m")
  19.     (setvar 'cmdecho 1)
  20.     (vl-cmdf "_.copy" s "" "_non" (getvar 'LASTPOINT) "_non" (getvar 'LASTPOINT))
  21.     (setq p1 (getvar 'LASTPOINT))
  22.     (vl-cmdf "_.move" s "" "_non" (getvar 'LASTPOINT) "_non" "\\")
  23.     (setq p2 (getvar 'LASTPOINT))
  24.     (setvar 'cmdecho 0)
  25.     (setq l (cons (getvar 'LASTPOINT) l))
  26.     (setq v (mapcar '- p2 p1))
  27.   )
  28.   (defun do_CC nil
  29.     (vl-cmdf "_.point" "_non" (if l (car l) (getvar 'LASTPOINT)))
  30.     (setq l (cons (trans (cdr (assoc 10 (entget (entlast)))) 0 1) l))
  31.     (setq sss (cons s sss))
  32.     (entdel (entlast))
  33.     (vl-cmdf "_.undo" "m")
  34.     (setvar 'cmdecho 1)
  35.     (vl-cmdf "_.copy" s "" "_non" (getvar 'LASTPOINT) "_non" (getvar 'LASTPOINT))
  36.     (if v
  37.       (vl-cmdf "_.move" s "" "_non" (getvar 'LASTPOINT) "_non" (mapcar '+ (getvar 'LASTPOINT) v))
  38.     )
  39.     (setvar 'cmdecho 0)
  40.     (setq l (cons (getvar 'LASTPOINT) l))
  41.   )
  42.   (defun do_CCC ( / n k kk pt d )
  43.     (vl-cmdf "_.point" "_non" (if l (car l) (getvar 'LASTPOINT)))
  44.     (setq l (cons (trans (cdr (assoc 10 (entget (entlast)))) 0 1) l))
  45.     (setq sss (cons s sss))
  46.     (entdel (entlast))
  47.     (vl-cmdf "_.undo" "m")
  48.     (initget 7)
  49.     (setq n (getint "\nEnter number of array items - (spaces) : "))
  50.     (setvar 'cmdecho 1)
  51.     (vl-cmdf "_.copy" s "" "_non" (getvar 'LASTPOINT) "_non" (getvar 'LASTPOINT))
  52.     (vl-cmdf "_.move" s "" "_non" (if llp (setq lp llp) (setq lp (getvar 'LASTPOINT))) "\\")
  53.     (setvar 'cmdecho 0)
  54.     (setq lllp (mapcar '- (setq llp (getvar 'LASTPOINT)) lp))
  55.     (setq k (float n))
  56.     (setq d (/ (distance lllp '(0.0 0.0 0.0)) k))
  57.     (prompt "\nUnit distance is : ") (princ (rtos d 2 8)) (getstring "\t ENTER TO CONTINUE")
  58.     (setq kk 0.0)
  59.     (repeat (- n 1)
  60.       (setq pt (mapcar '- lp (mapcar '* (list (* (setq kk (1+ kk)) (/ 1.0 k)) (* kk (/ 1.0 k)) (* kk (/ 1.0 k))) lllp)))
  61.       (vl-cmdf "_.copy" s "" "_non" lp "_non" pt)
  62.     )
  63.     (setvar 'LASTPOINT llp)
  64.     (setq l (cons llp l))
  65.   )
  66.   (defun do_M nil
  67.     (prompt "\nNext point : ")
  68.     (vl-cmdf "_.point" "_non" (if l (car l) (getvar 'LASTPOINT)))
  69.     (setq l (cons (trans (cdr (assoc 10 (entget (entlast)))) 0 1) l))
  70.     (setq sss (cons s sss))
  71.     (entdel (entlast))
  72.     (vl-cmdf "_.undo" "m")
  73.     (setvar 'cmdecho 1)
  74.     (setq p1 (getvar 'LASTPOINT))
  75.     (vl-cmdf "_.move" s "" "_non" (if llp (setq lp llp) (setq lp (getvar 'LASTPOINT))) "\\")
  76.     (setq p2 (getvar 'LASTPOINT))
  77.     (setvar 'cmdecho 0)
  78.     (setq l (cons (getvar 'LASTPOINT) l))
  79.     (setq v (mapcar '- p2 p1))
  80.   )
  81.   (defun do_MM nil
  82.     (vl-cmdf "_.point" "_non" (if l (car l) (getvar 'LASTPOINT)))
  83.     (setq l (cons (trans (cdr (assoc 10 (entget (entlast)))) 0 1) l))
  84.     (setq sss (cons s sss))
  85.     (entdel (entlast))
  86.     (vl-cmdf "_.undo" "m")
  87.     (setvar 'cmdecho 1)
  88.     (if v
  89.       (vl-cmdf "_.move" s "" "_non" (getvar 'LASTPOINT) "_non" (mapcar '+ (getvar 'LASTPOINT) v))
  90.     )
  91.     (setvar 'cmdecho 0)
  92.     (setq l (cons (getvar 'LASTPOINT) l))
  93.   )
  94.   (defun do_MI nil
  95.     (vl-cmdf "_.point" "_non" (if l (car l) (getvar 'LASTPOINT)))
  96.     (setq l (cons (trans (cdr (assoc 10 (entget (entlast)))) 0 1) l))
  97.     (setq sss (cons s sss))
  98.     (entdel (entlast))
  99.     (vl-cmdf "_.undo" "m")
  100.     (setvar 'cmdecho 1)
  101.     (vl-cmdf "_.mirror" s "" "_non" (if llp llp (setq lp (getvar 'LASTPOINT))) "_non" "\\" "\\")
  102.     (setvar 'cmdecho 0)
  103.   )
  104.   (defun do_R ( / lo g )
  105.     (setq lo T)
  106.     (while lo
  107.       (prompt "\nLEFT MOUSE CLICK FOR <MOUSE INPUT>; RIGHT MOUSE CLICK FOR <KEYBOARD INPUT>")
  108.       (setq g (grread nil 14 0))
  109.       (cond
  110.         ((eq (car g) 3) (do_RM))
  111.         ((or (eq (car g) 25) (eq (car g) 11)) (do_RK))
  112.       )
  113.     )
  114.   )
  115.   (defun do_RM ( / pt osm pola )
  116.     (setq osm (getvar 'OSMODE))
  117.     (setvar 'OSMODE 0)
  118.     (setq pola (getvar 'POLARANG))
  119.     (setvar 'POLARANG 0.0)
  120.     (prompt "\nAngle in decimal degrees <input angle with mouse> : ")
  121.     (vl-cmdf "_.point" "_non" (if l (car l) (getvar 'LASTPOINT)))
  122.     (setq l (cons (trans (cdr (assoc 10 (entget (entlast)))) 0 1) l))
  123.     (setq sss (cons s sss))
  124.     (entdel (entlast))
  125.     (vl-cmdf "_.undo" "m")
  126.     (setvar 'cmdecho 1)
  127.     (vl-cmdf "_.rotate" s "" "_non" (setq pt (if l (car l) (getvar 'LASTPOINT))) "\\")
  128.     (vl-cmdf "_.line" "_non" pt "_non" (cadr (grread 1)) "")
  129.     (setvar 'cmdecho 0)
  130.     (setq ang (atof (rtos (cvunit (getvar 'LASTANGLE) "radians" "degrees"))))
  131.     (setvar 'LASTPOINT pt)
  132.     (setvar 'OSMODE osm)
  133.     (setvar 'POLARANG pola)
  134.     (entdel (entlast))
  135.     (setq lo nil)
  136.   )
  137.   (defun do_RK ( / pt osm pola )
  138.     (setq osm (getvar 'OSMODE))
  139.     (setvar 'OSMODE 0)
  140.     (setq pola (getvar 'POLARANG))
  141.     (setvar 'POLARANG 0.0)
  142.     (initget 3)
  143.     (setq ang (getreal "\nAngle in decimal degrees <input angle with keyboard> : "))
  144.     (vl-cmdf "_.point" "_non" (if l (car l) (getvar 'LASTPOINT)))
  145.     (setq l (cons (trans (cdr (assoc 10 (entget (entlast)))) 0 1) l))
  146.     (setq sss (cons s sss))
  147.     (entdel (entlast))
  148.     (vl-cmdf "_.undo" "m")
  149.     (setvar 'cmdecho 1)
  150.     (vl-cmdf "_.rotate" s "" "_non" (setq pt (if l (car l) (getvar 'LASTPOINT))) ang)
  151.     (setvar 'cmdecho 0)
  152.     (setvar 'LASTPOINT pt)
  153.     (setvar 'OSMODE osm)
  154.     (setvar 'POLARANG pola)
  155.     (setq lo nil)
  156.   )
  157.   (defun do_RT nil
  158.     (vl-cmdf "_.point" "_non" (if l (car l) (getvar 'LASTPOINT)))
  159.     (setq l (cons (trans (cdr (assoc 10 (entget (entlast)))) 0 1) l))
  160.     (setq sss (cons s sss))
  161.     (entdel (entlast))
  162.     (vl-cmdf "_.undo" "m")
  163.     (setvar 'cmdecho 1)
  164.     (vl-cmdf "_.rotate" s "" "_non" (if l (car l) (getvar 'LASTPOINT)) 90)
  165.     (setvar 'cmdecho 0)
  166.   )
  167.   (defun do_RR nil
  168.     (vl-cmdf "_.point" "_non" (if l (car l) (getvar 'LASTPOINT)))
  169.     (setq l (cons (trans (cdr (assoc 10 (entget (entlast)))) 0 1) l))
  170.     (setq sss (cons s sss))
  171.     (entdel (entlast))
  172.     (vl-cmdf "_.undo" "m")
  173.     (setvar 'cmdecho 1)
  174.     (vl-cmdf "_.rotate" s "" "_non" (if l (car l) (getvar 'LASTPOINT)) "")
  175.     (setvar 'cmdecho 0)
  176.   )
  177.   (defun do_RRR nil
  178.     (vl-cmdf "_.point" "_non" (if l (car l) (getvar 'LASTPOINT)))
  179.     (setq l (cons (trans (cdr (assoc 10 (entget (entlast)))) 0 1) l))
  180.     (setq sss (cons s sss))
  181.     (entdel (entlast))
  182.     (vl-cmdf "_.undo" "m")
  183.     (setvar 'cmdecho 1)
  184.     (vl-cmdf "_.rotate" s "" "_non" (if l (car l) (getvar 'LASTPOINT)) (if ang (setq ang (- ang)) 0))
  185.     (setvar 'cmdecho 0)
  186.   )
  187.   (defun do_RRRR ( / lo g )
  188.     (setq lo T)
  189.     (while lo
  190.       (prompt "\nLEFT MOUSE CLICK FOR <MOUSE INPUT>; RIGHT MOUSE CLICK FOR <KEYBOARD INPUT>")
  191.       (setq g (grread nil 14 0))
  192.       (cond
  193.         ((eq (car g) 3) (do_RRRRM))
  194.         ((or (eq (car g) 25) (eq (car g) 11)) (do_RRRRK))
  195.       )
  196.     )
  197.   )
  198.   (defun do_RRRRM ( / loo g pt osm pola ss entl n k kk d )
  199.     (setq osm (getvar 'OSMODE))
  200.     (setvar 'OSMODE 0)
  201.     (setq pola (getvar 'POLARANG))
  202.     (setvar 'POLARANG 0.0)
  203.     (prompt "\nAngle in decimal degrees <input angle with mouse> : ")
  204.     (vl-cmdf "_.point" "_non" (if l (car l) (getvar 'LASTPOINT)))
  205.     (setq l (cons (trans (cdr (assoc 10 (entget (entlast)))) 0 1) l))
  206.     (setq sss (cons s sss))
  207.     (entdel (entlast))
  208.     (vl-cmdf "_.undo" "m")
  209.     (setvar 'cmdecho 1)
  210.     (vl-cmdf "_.copy" s "" "_non" (getvar 'LASTPOINT) "_non" (getvar 'LASTPOINT))
  211.     (vl-cmdf "_.rotate" s "" "_non" (setq pt (if l (car l) (getvar 'LASTPOINT))) "\\")
  212.     (vl-cmdf "_.line" "_non" pt "_non" (cadr (grread 1)) "")
  213.     (setvar 'cmdecho 0)
  214.     (setvar 'LASTPOINT pt)
  215.     (setq ang (atof (rtos (cvunit (getvar 'LASTANGLE) "radians" "degrees"))))
  216.     (entdel (entlast))
  217.     (setq loo T)
  218.     (while loo
  219.       (prompt "\nLEFT MOUSE CLICK FOR ANGLE LESS THAN 180 DEGREE; RIGHT MOUSE CLICK FOR ANGLE MORE THAN 180 DEGREE")
  220.       (setq g (grread nil 14 0))
  221.       (cond
  222.         ((eq (car g) 3) (setq loo nil))
  223.         ((or (eq (car g) 25) (eq (car g) 11)) (if (not (minusp ang)) (setq ang (- ang 360.0)) (setq ang (+ ang 360.0))) (setq loo nil))
  224.       )
  225.     )
  226.     (setq ss (ssadd))
  227.     (initget 6)
  228.     (setq n (getint "\nEnter number of array items - (spaces) <ENTER-rotate-1copy> : "))
  229.     (if (not (null n))
  230.       (progn
  231.         (setq k (float n))
  232.         (setq d (/ ang k))
  233.         (prompt "\nUnit angle is : ") (princ (rtos d 2 8)) (prompt "\t ENTER TO CONTINUE")
  234.         (vl-cmdf "\\")
  235.         (setq kk 0)
  236.         (repeat (- n 1)
  237.           (setq kk (1+ kk))
  238.           (if (= kk 1)
  239.             (progn
  240.               (setq entl (entlast))
  241.               (vl-cmdf "_.copy" s "" "_non" (getvar 'LASTPOINT) "_non" (getvar 'LASTPOINT))
  242.               (while (setq entl (entnext entl))
  243.                 (ssadd entl ss)
  244.               )
  245.               (setvar 'cmdecho 1)
  246.               (vl-cmdf "_.rotate" s "" "_non" (getvar 'LASTPOINT) (* (* -1.0 (/ 1.0 k)) ang))
  247.               (setvar 'cmdecho 0)
  248.             )
  249.             (progn
  250.               (setvar 'cmdecho 1)
  251.               (vl-cmdf "_.copy" s "" "_non" (getvar 'LASTPOINT) "_non" (getvar 'LASTPOINT))
  252.               (vl-cmdf "_.rotate" s "" "_non" (getvar 'LASTPOINT) (* (* -1.0 (/ 1.0 k)) ang))
  253.               (setvar 'cmdecho 0)
  254.             )
  255.           )
  256.         )
  257.       )
  258.     )
  259.     (if (/= (sslength ss) 0) (setq s ss))
  260.     (setvar 'LASTPOINT pt)
  261.     (setvar 'OSMODE osm)
  262.     (setvar 'POLARANG pola)
  263.     (setq lo nil)
  264.   )
  265.   (defun do_RRRRK ( / pt osm pola ss entl n k kk d )
  266.     (setq osm (getvar 'OSMODE))
  267.     (setvar 'OSMODE 0)
  268.     (setq pola (getvar 'POLARANG))
  269.     (setvar 'POLARANG 0.0)
  270.     (initget 3)
  271.     (setq ang (getreal "\nAngle in decimal degrees <input angle with keyboard> : "))
  272.     (vl-cmdf "_.point" "_non" (if l (car l) (getvar 'LASTPOINT)))
  273.     (setq l (cons (trans (cdr (assoc 10 (entget (entlast)))) 0 1) l))
  274.     (setq sss (cons s sss))
  275.     (entdel (entlast))
  276.     (vl-cmdf "_.undo" "m")
  277.     (setvar 'cmdecho 1)
  278.     (vl-cmdf "_.copy" s "" "_non" (getvar 'LASTPOINT) "_non" (getvar 'LASTPOINT))
  279.     (vl-cmdf "_.rotate" s "" "_non" (if l (car l) (getvar 'LASTPOINT)) ang)
  280.     (setvar 'cmdecho 0)
  281.     (setq ss (ssadd))
  282.     (initget 6)
  283.     (setq n (getint "\nEnter number of array items - (spaces) <ENTER-rotate-1copy> : "))
  284.     (if (not (null n))
  285.       (progn
  286.         (setq k (float n))
  287.         (setq d (/ ang k))
  288.         (prompt "\nUnit angle is : ") (princ (rtos d 2 8)) (prompt "\t ENTER TO CONTINUE")
  289.         (vl-cmdf "\\")
  290.         (setq kk 0)
  291.         (repeat (- n 1)
  292.           (setq kk (1+ kk))
  293.           (if (= kk 1)
  294.             (progn
  295.               (setq entl (entlast))
  296.               (setvar 'cmdecho 1)
  297.               (vl-cmdf "_.copy" s "" "_non" (getvar 'LASTPOINT) "_non" (getvar 'LASTPOINT))
  298.               (setvar 'cmdecho 0)
  299.               (while (setq entl (entnext entl))
  300.                 (ssadd entl ss)
  301.               )
  302.               (setvar 'cmdecho 1)
  303.               (vl-cmdf "_.rotate" s "" "_non" (getvar 'LASTPOINT) (* (* -1.0 (/ 1.0 k)) ang))
  304.               (setvar 'cmdecho 0)
  305.             )
  306.             (progn
  307.               (setvar 'cmdecho 1)
  308.               (vl-cmdf "_.copy" s "" "_non" (getvar 'LASTPOINT) "_non" (getvar 'LASTPOINT))
  309.               (vl-cmdf "_.rotate" s "" "_non" (getvar 'LASTPOINT) (* (* -1.0 (/ 1.0 k)) ang))
  310.               (setvar 'cmdecho 0)
  311.             )
  312.           )
  313.         )
  314.       )
  315.     )
  316.     (if (/= (sslength ss) 0) (setq s ss))
  317.     (setq l (cons (trans (getvar 'LASTPOINT) 0 1) l))
  318.     (setvar 'OSMODE osm)
  319.     (setvar 'POLARANG pola)
  320.     (setq lo nil)
  321.   )
  322.   (defun do_U nil
  323.     (vl-cmdf "_.undo" "b")
  324.     (setq s (car sss))
  325.     (setvar 'LASTPOINT (car l))
  326.     (setq l (cdr l))
  327.     (setq sss (cdr sss))
  328.   )
  329.   (defun do_AL nil
  330.     (vl-cmdf "_.point" "_non" (if l (car l) (getvar 'LASTPOINT)))
  331.     (setq l (cons (trans (cdr (assoc 10 (entget (entlast)))) 0 1) l))
  332.     (setq sss (cons s sss))
  333.     (entdel (entlast))
  334.     (vl-cmdf "_.undo" "m")
  335.     (setvar 'cmdecho 1)
  336.     (vl-cmdf "._point" "_non" (car l))
  337.     (vl-cmdf "_.align" (ssadd (setq p (entlast)) s) "")
  338.     (while (< 0 (getvar 'cmdactive))
  339.       (vl-cmdf "\\")
  340.     )
  341.     (setvar 'cmdecho 0)
  342.     (setq l (cons (trans (cdr (assoc 10 (entget p))) 0 1) l))
  343.     (entdel p)
  344.     (setvar 'LASTPOINT (car l))
  345.   )
  346.   (defun do_L nil
  347.     (vl-cmdf "_.point" "_non" (if l (car l) (getvar 'LASTPOINT)))
  348.     (setq l (cons (trans (cdr (assoc 10 (entget (entlast)))) 0 1) l))
  349.     (setq sss (cons s sss))
  350.     (entdel (entlast))
  351.     (vl-cmdf "_.undo" "m")
  352.     (setvar 'cmdecho 1)
  353.     (vl-cmdf "._scale" (car sss) "" "_non" (car l))
  354.     (while (< 0 (getvar 'cmdactive))
  355.       (vl-cmdf "\\")
  356.     )
  357.     (setvar 'cmdecho 0)
  358.   )
  359.   (defun mcr ( / loop gr sss l lp llp lllp )
  360.     (setq loop T)
  361.     (if (not (eq s nil))
  362.       (while loop
  363.         (prompt "\n\"S\" key for new selection and basepoint; \"P\" key for base point; \t\"C\" key for copy; \"W\" key for copy-array; \"D\" key for copy-continuous; \"A\" key for align; \"M\" key for move; \"N\" key for move-continuous; \t\"I\" key for mirror; \t\"R\" key for rotate; \"T\" key for rotate-again; \"E\" key for rotate-previous; \"Y\" key for rotate-array; \"L\" key for scale; \"TAB\" key for rotate by 90 degree; \"U\" key for undo; ESC, right mouse click to end")
  364.         (setq gr (grread nil 14 0))
  365.         (cond
  366.           ((or (equal gr '(2 115)) (equal gr '(2 83))) (progn (setq s nil) (mcr)))
  367.           ((or (equal gr '(2 112)) (equal gr '(2 80))) (progn (setq p (getpoint "\nPick base point : ")) (setq llp nil) (setvar 'LASTPOINT p)))
  368.           ((or (equal gr '(2 99)) (equal gr '(2 67))) (do_C))
  369.           ((or (equal gr '(2 100)) (equal gr '(2 68))) (do_CC))
  370.           ((or (equal gr '(2 119)) (equal gr '(2 87))) (do_CCC))
  371.           ((or (equal gr '(2 109)) (equal gr '(2 77))) (do_M))
  372.           ((or (equal gr '(2 110)) (equal gr '(2 78))) (do_MM))
  373.           ((or (equal gr '(2 105)) (equal gr '(2 73))) (do_MI))
  374.           ((or (equal gr '(2 114)) (equal gr '(2 82))) (do_R))
  375.           ((or (equal gr '(2 116)) (equal gr '(2 84))) (do_RR))
  376.           ((or (equal gr '(2 101)) (equal gr '(2 69))) (do_RRR))
  377.           ((or (equal gr '(2 121)) (equal gr '(2 89))) (do_RRRR))
  378.           ((or (equal gr '(2 97)) (equal gr '(2 65))) (do_AL))
  379.           ((or (equal gr '(2 108)) (equal gr '(2 76))) (do_L))
  380.           ((or (equal gr '(2 117)) (equal gr '(2 85))) (do_U))
  381.           ((equal gr '(2 9)) (do_RT))
  382.           ((or (equal gr '(2 27)) (eq (car gr) 25) (eq (car gr) 11)) (setq loop nil))
  383.         )
  384.       )
  385.       (progn
  386.         (setq s (ssget "_:L"))
  387.         (setq p (getpoint "\nPick base point : "))
  388.         (setvar 'LASTPOINT p)
  389.         (mcr)
  390.       )
  391.     )
  392.   )
  393.   (mcr)
  394.   (*error* nil)
  395. )
  396.  

M.R.
 8-)
Title: Re: Copy and rotate (kopieren und drehen)
Post by: Hugo on October 09, 2012, 12:33:56 AM
super Thanks
I can really use

super Danke
kann ich gut gebrauchen
Title: Re: Copy and rotate (kopieren und drehen)
Post by: ribarm on October 09, 2012, 07:59:05 AM
super Thanks
I can really use

super Danke
kann ich gut gebrauchen

Two variables haven't been localized, so now you can use it with full reliability...
Zwei Variablen wurden nicht lokalisiert, so jetzt können Sie es mit voller Zuverlässigkeit verwenden...

M.R.
Title: Re: Copy and rotate (kopieren und drehen)
Post by: thuphong on October 09, 2012, 09:16:32 AM
Thank ribarm.
Why I click Right mouse for rotation is no active, but if (eq (car gr) 11)) is OK

Title: Re: Copy and rotate (kopieren und drehen)
Post by: ribarm on October 09, 2012, 09:42:14 AM
Thank ribarm.
Why I click Right mouse for rotation is no active, but if (eq (car gr) 11)) is OK

On my comp. right mouse click is recognized with (eq (car g) 25), but if you have problems with this and with value 11 it works for you, then you use what suits you best... With right mouse click you enter subfunction for keyboard input where all 360 degrees angles are allowed... If you haven't noticed (getvar 'LASTANGLE) returns always angle from -PI to PI, so rotate-array with mouse click is always by angle < 180 degree - if you really have the need for rotate-array I strongly suggest that you use keyboard input - full angles up to 360 degree...

M.R.
Title: Re: Copy and rotate (kopieren und drehen)
Post by: ribarm on October 09, 2012, 10:44:55 AM
Here, I've updated code once more and finally - it should operate OK and with your case - value 11 of (car (grread)) for right mouse click... I've also included angles more than 180 degree in rotate-array with mouse input - had to add one more mouse click choice...

Regards, M.R.
 :-)
Title: Re: Copy and rotate (kopieren und drehen)
Post by: thuphong on October 09, 2012, 09:54:40 PM
Here, I've updated code once more and finally - it should operate OK and with your case - value 11 of (car (grread)) for right mouse click... I've also included angles more than 180 degree in rotate-array with mouse input - had to add one more mouse click choice...

Regards, M.R.
 :-)
Thank verry much ribarm   
 :-D :-D
Title: Re: Copy and rotate (kopieren und drehen)
Post by: ribarm on December 18, 2012, 08:34:25 AM
Modified little bit more to be more logical with array options (array-copy & array-rotate)... Now it asks for number of items (spaces) and measures unit distance or unit angle... Consider that you should divide distance or angle and then when using routine compare these values to be sure all is OK...

Regards, and Happy Holidays, M.R.
 :wink:
Title: Re: Copy and rotate (kopieren und drehen)
Post by: 77077 on September 29, 2014, 12:56:57 AM
wow. many sample, I love it ,thanks!