Need help to modify code "rotate block for preview prior pick point to insert block"

le-tan-phuc · ‎05-16-2024

I found Lee Mac's code at this link:
https://www.theswamp.org/index.php?topic=40686.0
but I can't execute the block rotation function when pressing the ESC key (when I press ESC it exits the command)
Can someone please help me if possible:
1. Change the block rotation function to the R key
2.maintain the block insertion command until the Enter or ESC key is pressed

Here is the code

(defun c:test ( / b c r )
(setq r 0.0)
(setq c (getvar 'CMDECHO))
(setvar 'CMDECHO 0)
(while
(not
(or
(eq "" (setq b (getstring t "\nBlock to Insert: ")))
(tblsearch "BLOCK" b)
)
)
(princ "\nBlock not found.")
)
(if (not (eq "" b))
(while
(progn
(princ "\nSpecify Insertion Point (Esc to Rotate): ")
(null (vl-cmdf "_.-insert" b "_S" 1.0 "_R" (* 180. (/ r pi)) pause))
)
(setq r (rem (+ r (/ pi 2.)) (+ pi pi)))
)
)
(setvar 'CMDECHO c)
(princ)
)
(vl-load-com)

Sea-Haven · ‎05-16-2024

This works for me with a pause to select rotation.

(command "-INSERT" b (getpoint "\nPick point ") 1 1 pause)

You can see block rotating.

le-tan-phuc · ‎05-16-2024

can you post the complete code please. I'm not good at LISP programing

Sea-Haven · ‎05-17-2024

Try this I am sure others will provide alternatives.

(defun c:test ( / r c b )
    (setq r 0.0)
    (setq c (getvar 'CMDECHO))
    (setvar 'CMDECHO 0)
    (while  (setq b (getstring t "\nBlock to Insert Enter to exit "))
       (if (= (tblsearch "BLOCK" b) nil)
        (progn  
		  (Alert "\nBlock not found.\n\nWill now exit please try again ")
		  (exit)
		)
		(progn 
		  (command "-INSERT" b (setq pt (getpoint "\nPick insertion point ")) 1 1 pause)
		  (setq ent (entlast))
		  (setq r (cdr (assoc 50 (entget ent))))
		)
       )
    (while (setq npt (getpoint "\nPick new insertion point Enter to exit "))
       (command "copy" ent "" pt npt)
    )
    )
    (setvar 'CMDECHO c)
    (princ)
)
(vl-load-com)
(c:test)

le-tan-phuc · ‎05-17-2024

Thank you for reply, but it doesn't work as I expected, I think this problem is quite difficult to make it work.

Sea-Haven · ‎05-17-2024

What doesn't work please explain ? Do you want the block rotated each time inserted a set amount ?

le-tan-phuc · ‎05-17-2024

I think I have found the answer here, (solution by BeekeeCZ)

https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/block-insert-rotate-on-tab-key-each-...

marko_ribar · ‎05-18-2024

I took some time to modify CAB's code and added GrSnap, so that insertion of blocks is performed precisely...

Here is my version...

;;  This is a kludge of a routine that will allow rotation via the L fo CCW and R for CW
;;  rotation while moving the block. If you are through rotating and want the osnap to
;;  work press shift+right click to make another setting then currently set 'osmode'.

(defun c:ins+rot_L-R+osnap ( / LM:acapp *error* GrSnap-subs cmd ape osm pdm bname loop key ll grr ip lastpt ent ch )

  ;; Application Object  -  Lee Mac
  ;; Returns the VLA Application Object
  ;; Mod. by M.R.

  (defun LM:acapp nil
    (eval
      (list 'defun 'LM:acapp '( / cad ) 
        (if (vl-catch-all-error-p (setq cad (vl-catch-all-apply (function vlax-get-acad-object) nil)))
          (progn (vl-load-com) (vlax-get-acad-object))
          cad
        )
      )
    )
    (LM:acapp)
  )

  (defun *error* ( m )
    (if ll
      (progn
        (foreach x ll
          (setq x nil)
        )
        (setq ll nil)
      )
    )
    (if command-s
      (command-s "_.undo" "_end")
      (vl-cmdf "_.undo" "_end")
    )
    (if cmd (setvar (quote cmdecho) cmd))
    (if ape (setvar (quote aperture) ape))
    (if osm (setvar (quote osmode) osm))
    (if pdm (setvar (quote pdmode) pdm))
    (if doc (vla-regen doc acactiveviewport))
    (if m (prompt m))
    (princ)
  )

  (defun GrSnap-subs nil
    (eval
      (progn

        ;; Object Snap for grread: Snap Function  -  Lee Mac
        ;; Returns: [fun] A function requiring two arguments:
        ;; p - [lst] UCS Point to be snapped
        ;; o - [int] Object Snap bit code
        ;; The returned function returns either the snapped point (displaying an appropriate snap symbol)
        ;; or the supplied point if the snap failed for the given Object Snap bit code.

        (defun LM:grsnap:snapfunction ( )
          (eval
            (list 'lambda '( p o / q )
              (list 'if '(zerop (logand 16384 o))
                (list 'if
                 '(setq q
                    (cdar
                      (vl-sort
                        (vl-remove-if 'null
                          (mapcar
                            (function
                              (lambda ( a / b )
                                (if (and (= (car a) (logand (car a) o)) (setq b (osnap p (cdr a))))
                                  (list (distance p b) b (car a))
                                )
                              )
                            )
                           '(
                              (0001 . "_end")
                              (0002 . "_mid")
                              (0004 . "_cen")
                              (0008 . "_nod")
                              (0016 . "_qua")
                              (0032 . "_int")
                              (0064 . "_ins")
                              (0128 . "_per")
                              (0256 . "_tan")
                              (0512 . "_nea")
                              (2048 . "_app")
                              (8192 . "_par")
                            )
                          )
                        )
                        (function (lambda ( a b ) (< (car a) (car b))))
                      )
                    )
                  )
                  (list 'LM:grsnap:displaysnap '(car q)
                    (list 'cdr
                      (list 'assoc '(cadr q)
                        (list 'quote
                          (LM:grsnap:snapsymbols
                            (atoi (cond ((getenv "AutoSnapSize")) ("5")))
                          )
                        )
                      )
                    )
                    (LM:OLE->ACI
                      (if (= 1 (getvar 'cvport))
                        (atoi (cond ((getenv "Layout AutoSnap Color")) ("117761")))
                        (atoi (cond ((getenv  "Model AutoSnap Color")) ("104193")))
                      )
                    )
                  )
                )
              )
             '(cond ((car q)) (p))
            )
          )
        )

        ;; Object Snap for grread: Display Snap  -  Lee Mac
        ;; pnt - [lst] UCS point at which to display the symbol
        ;; lst - [lst] grvecs vector list
        ;; col - [int] ACI colour for displayed symbol
        ;; Returns nil

        (defun LM:grsnap:displaysnap ( pnt lst col / scl )
          (setq scl (/ (getvar 'viewsize) (cadr (getvar 'screensize))))
          (setq pnt (trans pnt 1 1))
          (grvecs (cons col (mapcar (function (lambda ( x ) (mapcar (function +) (mapcar (function *) x (list scl scl)) pnt))) lst))
            ;|
            (list
              (list 1.0 0.0 0.0 0.0)
              (list 0.0 1.0 0.0 0.0)
              (list 0.0 0.0 1.0 0.0)
              (list 0.0 0.0 0.0 1.0)
            ) ;;; This matrix is for presentation of vectors - start/end points should be supplied in DCS ; if you omit matrix - start/end points should be supplied in UCS
            |;
          )
        )

        ;; Object Snap for grread: Snap Symbols  -  Lee Mac
        ;; p - [int] Size of snap symbol in pixels
        ;; Returns: [lst] List of vector lists describing each Object Snap symbol

        (defun LM:grsnap:snapsymbols ( p / -p -q -r a c i l q r )
          (setq -p (- p) q (1+  p)
                -q (- q) r (+ 2 p)
                -r (- r) i (/ pi 6)
                 a 0.0
          )
          (repeat 12
            (setq l (cons (list (* r (cos a)) (* r (sin a))) l)
                  a (- a i)
            )
          )
          (setq c (apply 'append (mapcar 'list (cons (last l) l) l)))
          (list
            (list 0001
              (list -p -p) (list p -p) (list p -p) (list p p) (list p p) (list -p p) (list -p p) (list -p -p)
              (list -q -q) (list q -q) (list q -q) (list q q) (list q q) (list -q q) (list -q q) (list -q -q)
            )
            (list 0002
              (list -r -q) (list 0  r) (list 0  r) (list r -q)
              (list -p -p) (list p -p) (list p -p) (list 0  p) (list 0  p) (list -p -p)
              (list -q -q) (list q -q) (list q -q) (list 0  q) (list 0  q) (list -q -q)
            )
            (cons 0004 c)
            (vl-list* 0008 (list -r -r) (list r r) (list r -r) (list -r r) c)
            (list 0016
              (list p 0) (list 0 p) (list 0 p) (list -p 0) (list -p 0) (list 0 -p) (list 0 -p) (list p 0)
              (list q 0) (list 0 q) (list 0 q) (list -q 0) (list -q 0) (list 0 -q) (list 0 -q) (list q 0)
              (list r 0) (list 0 r) (list 0 r) (list -r 0) (list -r 0) (list 0 -r) (list 0 -r) (list r 0)
            )
            (list 0032
              (list  r r) (list -r -r) (list  r q) (list -q -r) (list  q r) (list -r -q)
              (list -r r) (list  r -r) (list -q r) (list  r -q) (list -r q) (list  q -r)
            )
            (list 0064
              '( 0  1) (list  0  p) (list  0  p) (list -p  p) (list -p  p) (list -p -1) (list -p -1) '( 0 -1)
              '( 0 -1) (list  0 -p) (list  0 -p) (list  p -p) (list  p -p) (list  p  1) (list  p  1) '( 0  1)
              '( 1  2) (list  1  q) (list  1  q) (list -q  q) (list -q  q) (list -q -2) (list -q -2) '(-1 -2)
              '(-1 -2) (list -1 -q) (list -1 -q) (list  q -q) (list  q -q) (list  q  2) (list  q  2) '( 1  2)
            )
            (list 0128
              (list (1+ -p) 0) '(0 0) '(0 0) (list 0 (1+ -p))
              (list (1+ -p) 1) '(1 1) '(1 1) (list 1 (1+ -p))
              (list -p q) (list -p -p) (list -p -p) (list q -p)
              (list -q q) (list -q -q) (list -q -q) (list q -q)
            )
            (vl-list* 256 (list -r r)  (list r r) (list -r (1+ r)) (list r (1+ r)) c)
            (list 0512
              (list -p -p) (list  p -p) (list -p  p) (list p p) (list -q -q) (list  q -q)
              (list  q -q) (list -q  q) (list -q  q) (list q q) (list  q  q) (list -q -q)
            )
            (list 2048
              (list   -p     -p) (list    p      p) (list   -p      p) (list    p     -p)
              (list (+ p 05) -p) (list (+ p 06) -p) (list (+ p 05) -q) (list (+ p 06) -q)
              (list (+ p 09) -p) (list (+ p 10) -p) (list (+ p 09) -q) (list (+ p 10) -q)
              (list (+ p 13) -p) (list (+ p 14) -p) (list (+ p 13) -q) (list (+ p 14) -q)
              (list -p -p) (list p -p) (list p -p) (list p p) (list p p) (list -p p) (list -p p) (list -p -p)
              (list -q -q) (list q -q) (list q -q) (list q q) (list q q) (list -q q) (list -q q) (list -q -q)
            )
            (list 8192 (list r 1) (list -r -q) (list r 0) (list -r -r) (list r q) (list -r -1) (list r r) (list -r 0))
          )
        )

        ;; Object Snap for grread: Parse Point  -  Lee Mac
        ;; bpt - [lst] Basepoint for relative point input, e.g. @5,5
        ;; str - [str] String representing point input
        ;; Returns: [lst] Point represented by the given string, else nil

        (defun LM:grsnap:parsepoint ( bpt str / str->lst lst )

          (defun str->lst ( str / pos )
            (if (setq pos (vl-string-position 44 str))
              (cons (substr str 1 pos) (str->lst (substr str (+ pos 2))))
              (list str)
            )
          )

          (if (wcmatch str "`@*")
              (setq str (substr str 2))
              (setq bpt (list 0.0 0.0 0.0))
          )
          (if
            (and
              (setq lst (mapcar (function distof) (str->lst str)))
              (vl-every (function numberp) lst)
              (< 1 (length lst) 4)
            )
            (mapcar (function +) bpt lst)
          )
        )

        ;; Object Snap for grread: Snap Mode  -  Lee Mac
        ;; str - [str] Object Snap modifier
        ;; Returns: [int] Object Snap bit code for the given modifier, else nil

        (defun LM:grsnap:snapmode ( str )
          (vl-some
            (function
              (lambda ( x )
                (if (wcmatch (car x) (strcat (strcase str t) "*"))
                  (progn (setq ff t) (princ (cadr x)) (caddr x))
                )
              )
            )
           '(
              ("endpoint"      " of " 0001)
              ("midpoint"      " of " 0002)
              ("center"        " of " 0004)
              ("node"          " of " 0008)
              ("quadrant"      " of " 0016)
              ("intersection"  " of " 0032)
              ("insert"        " of " 0064)
              ("perpendicular" " to " 0128)
              ("tangent"       " to " 0256)
              ("nearest"       " to " 0512)
              ("appint"        " of " 2048)
              ("parallel"      " to " 8192)
              ("none"          ""     16384)
            )
          )
        )

        ;; OLE -> ACI  -  Lee Mac
        ;; Args: c - [int] OLE Colour
        (defun LM:OLE->ACI ( c )
          (apply (function LM:RGB->ACI) (LM:OLE->RGB c))
        )

        ;; OLE -> RGB  -  Lee Mac
        ;; Args: c - [int] OLE Colour
        (defun LM:OLE->RGB ( c )
          (mapcar (function (lambda ( x ) (lsh (lsh (fix c) x) -24))) (list 24 16 8))
        )

        ;; RGB -> ACI  -  Lee Mac
        ;; Args: r,g,b - [int] Red, Green, Blue values
        (defun LM:RGB->ACI ( r g b / c o )
          (if (setq o (vla-getinterfaceobject (LM:acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
            (progn
              (setq c (vl-catch-all-apply (function (lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o)))))
              (vlax-release-object o)
              (if (vl-catch-all-error-p c)
                (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
                c
              )
            )
          )
        )

      )
    )
  ) ;;; end GrSnap-subs

  (GrSnap-subs)
  (setq ll (list 'LM:grsnap:snapfunction 'LM:grsnap:displaysnap 'LM:grsnap:snapsymbols 'LM:grsnap:parsepoint 'LM:grsnap:snapmode 'LM:OLE->ACI 'LM:OLE->RGB 'LM:RGB->ACI))
  (setq doc (vla-get-activedocument (LM:acapp)))
  (setq spc (vla-get-block (setq alo (vla-get-activelayout doc))))
  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (setq ape (getvar (quote aperture)))
  (setvar (quote aperture) 10)
  (setq pdm (getvar (quote pdmode)))
  (setvar (quote pdmode) 35)
  (setq osf (LM:grsnap:snapfunction))
  (setq osm (getvar (quote osmode)))
  (if (equal 0 (getvar (quote undoctl)))
    (if command-s
      (command-s "_.undo" "_all")
      (vl-cmdf "_.undo" "_all")
    )
  )
  (if
    (or
      (not (equal 1 (logand 1 (getvar (quote undoctl)))))
      (equal 2 (logand 2 (getvar (quote undoctl))))
    )
    (if command-s
      (command-s "_.undo" "_control" "_all")
      (vl-cmdf "_.undo" "_control" "_all")
    )
  )
  (if (equal 4 (logand 4 (getvar (quote undoctl))))
    (if command-s
      (command-s "_.undo" "_auto" "_off")
      (vl-cmdf "_.undo" "_auto" "_off")
    )
  )
  (while (equal 8 (logand 8 (getvar (quote undoctl))))
    (if command-s
      (command-s "_.undo" "_end")
      (vl-cmdf "_.undo" "_end")
    )
  )
  (if command-s
    (command-s "_.undo" "_begin")
    (vl-cmdf "_.undo" "_begin")
  )
  (while
    (not
      (or
        (eq "" (setq bname (getstring t "\nBlock to Insert: ")))
        (tblsearch "BLOCK" bname)
      )
    )
    (princ "\nBlock not found.")
  )
  (setq loop t)
  (while (and loop (setq grr (grread t 7 0)));  exit on ENTER or picked point
    (redraw)
    (setq loop
      (cond
        ;;=====================================================
        ((= 2 (car grr)) ; keyboard input
         (setq key (cadr grr))
         (cond
           ;;-------------------------------------------
           ((= key 13) ; ENTER- where done here
            (and ent (entdel ent))
            (princ "\nUser Quit.")
            nil ; exit loop
           )
           ;;-------------------------------------------
           ((member (chr key) '("I" "i")) ; Insert with OSNAP
             (vl-cmdf "_.move" ent "" "_non" lastpt)
             (while (= (logand (getvar "cmdactive") 1) 1)
               (vl-cmdf "\\")
             )
             nil ; exit loop
           )
           ((member (chr key) '("L" "l")) ; Left or CCW
             (vl-cmdf "_.rotate" ent "" "_non" ip 90.0)
             t ; stay in loop
           )
           ((member (chr key) '("R" "r")) ; Right or CW
             (vl-cmdf "_.rotate" ent "" "_non" ip -90.0)
             t ; stay in loop
           )
           ;;-------------------------------------------
           ((princ "\nInvalid Keypress.") t)
         ) ; end cond
        )
        ;;=====================================================
        ((= 3 (car grr)) ; point picked, make final insertion
         (setq ip (osf (cadr grr) osm))
         nil ; exit
        )
        ;;=====================================================
        ((or (= 12 (car grr)) (= 5 (car grr))) ; point from mouse, update object
         (setq ip (osf (cadr grr) osm))
         (if (not lastpt) ; first time through
           (progn
             (setq lastpt ip)
             (vl-cmdf "_.-insert" bname "_S" 1.0 "_R" 0.0 "_non" ip)
             (setq ent (entlast))
           )
         )
         (if (> (distance ip lastpt) 0.00001)
           (vl-cmdf "_.move" ent "" "_non" lastpt "_non" ip)
         )
         (setq lastpt ip)
        )
        ((and (= (car grr) 11) (= (cadr grr) 1000)) ; shift+right click
         (progn
           (initdia)
           (if command-s
             (command-s "_.osnap")
             (vl-cmdf "_.osnap")
           )
           (setq osm (getvar (quote osmode)))
           t   ; stay in loop
         )
        )
      )   ; end cond
    )   ; end (setq loop)
    ;;=====================================================
  )   ; while
  (initget "Yes No")
  (setq ch (cond ( (getkword "\nDo you want to explode and purge inserted block [Yes/No]  : ") ) ("Yes")))
  (if (= ch "Yes")
    (progn
      (vl-cmdf "_.explode" (entlast))
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
      (vl-cmdf "_.-purge" "_b" bname "_n")
    )
  )
  (*error* nil)
)

HTH.

M.R.

Marko Ribar, d.i.a. (graduated engineer of architecture)

le-tan-phuc · ‎05-19-2024

Thank you Marko Ribar !

marko_ribar · ‎05-20-2024

I just wanted to say that I slightly changed end of my routine and add new smaller one which goes in combination with that one that was accepted as solution... You use firstly "copyents2blk" and then "ins+rot_L-R+osnap"...

(defun c:copyents2blk ( / effectivename s p blkname )

  (defun effectivename ( ent / blk rep )
    (if (wcmatch (setq blk (cdr (assoc 2 (entget ent)))) "`**")
      (if
        (and
          (setq rep
            (cdadr
              (assoc -3
                (entget
                  (cdr
                    (assoc 330
                      (entget
                          (tblobjname "block" blk)
                      )
                    )
                  )
                 '("AcDbBlockRepBTag")
                )
              )
            )
          )
          (setq rep (handent (cdr (assoc 1005 rep))))
        )
        (setq blk (cdr (assoc 2 (entget rep))))
      )
    )
    blk
  )

  (prompt "\nSelect entities on unlocked layer(s) to make block after which you can use \"ins+rot_L-R+osnap\" routine...")
  (if
    (and
      (setq s (ssget "_:L"))
      (not (initget 1))
      (setq p (getpoint "\nPick or specify base point : "))
    )
    (progn
      (vl-cmdf "_.copybase" "_non" p s "")
      (vl-cmdf "_.pasteblock" "_non" p)
      (if (not (vl-catch-all-error-p (setq blkname (vl-catch-all-apply (function effectivename) (list (entlast))))))
        (prompt (strcat "\nBlock name to use with \"ins+rot_L-R+osnap\" routine is : " blkname))
        (progn
          (setq blkname (cdr (assoc 2 (entget (entlast)))))
          (prompt (strcat "\nBlock name to use with \"ins+rot_L-R+osnap\" routine is : " blkname))
        )
      )
      (entdel (entlast))
    )
  )
  (princ)
)

HTH.

M.R.

Marko Ribar, d.i.a. (graduated engineer of architecture)

marko_ribar · ‎05-20-2024

I unioned last 2 codes into single powerful routine...

Here you are :

(defun c:mcrot+osnap ( / *error* effectivename LM:acapp ins+rot_L-R+osnap ll uf s bp blkname cmd ape osm pdm )

  (defun *error* ( m )
    (if ll
      (progn
        (foreach x ll
          (setq x nil)
        )
        (setq ll nil)
      )
    )
    (if uf
      (if command-s
        (command-s "_.ucs" "_p")
        (vl-cmdf "_.ucs" "_p")
      )
    )
    (if command-s
      (command-s "_.undo" "_end")
      (vl-cmdf "_.undo" "_end")
    )
    (if cmd (setvar (quote cmdecho) cmd))
    (if ape (setvar (quote aperture) ape))
    (if osm (setvar (quote osmode) osm))
    (if pdm (setvar (quote pdmode) pdm))
    (if doc (vla-regen doc acactiveviewport))
    (if m (prompt m))
    (princ)
  )

  (defun effectivename ( ent / blk rep )
    (if (wcmatch (setq blk (cdr (assoc 2 (entget ent)))) "`**")
      (if
        (and
          (setq rep
            (cdadr
              (assoc -3
                (entget
                  (cdr
                    (assoc 330
                      (entget
                          (tblobjname "block" blk)
                      )
                    )
                  )
                 '("AcDbBlockRepBTag")
                )
              )
            )
          )
          (setq rep (handent (cdr (assoc 1005 rep))))
        )
        (setq blk (cdr (assoc 2 (entget rep))))
      )
    )
    blk
  )

  ;; Application Object  -  Lee Mac
  ;; Returns the VLA Application Object
  ;; Mod. by M.R.

  (defun LM:acapp nil
    (eval
      (list 'defun 'LM:acapp '( / cad ) 
        (if (vl-catch-all-error-p (setq cad (vl-catch-all-apply (function vlax-get-acad-object) nil)))
          (progn (vl-load-com) (vlax-get-acad-object))
          cad
        )
      )
    )
    (LM:acapp)
  )

  ;;  This is a kludge of a routine that will allow rotation via the L fo CCW and R for CW
  ;;  rotation while moving the block. If you are through rotating and want the osnap to
  ;;  work press shift+right click to make another setting then currently set 'osmode'.

  (defun ins+rot_L-R+osnap ( bname / GrSnap-subs loop key grr ip lastpt ent ch )

    (defun GrSnap-subs nil
      (eval
        (progn

          ;; Object Snap for grread: Snap Function  -  Lee Mac
          ;; Returns: [fun] A function requiring two arguments:
          ;; p - [lst] UCS Point to be snapped
          ;; o - [int] Object Snap bit code
          ;; The returned function returns either the snapped point (displaying an appropriate snap symbol)
          ;; or the supplied point if the snap failed for the given Object Snap bit code.

          (defun LM:grsnap:snapfunction ( )
            (eval
              (list 'lambda '( p o / q )
                (list 'if '(zerop (logand 16384 o))
                  (list 'if
                   '(setq q
                      (cdar
                        (vl-sort
                          (vl-remove-if 'null
                            (mapcar
                              (function
                                (lambda ( a / b )
                                  (if (and (= (car a) (logand (car a) o)) (setq b (osnap p (cdr a))))
                                    (list (distance p b) b (car a))
                                  )
                                )
                              )
                             '(
                                (0001 . "_end")
                                (0002 . "_mid")
                                (0004 . "_cen")
                                (0008 . "_nod")
                                (0016 . "_qua")
                                (0032 . "_int")
                                (0064 . "_ins")
                                (0128 . "_per")
                                (0256 . "_tan")
                                (0512 . "_nea")
                                (2048 . "_app")
                                (8192 . "_par")
                              )
                            )
                          )
                          (function (lambda ( a b ) (< (car a) (car b))))
                        )
                      )
                    )
                    (list 'LM:grsnap:displaysnap '(car q)
                      (list 'cdr
                        (list 'assoc '(cadr q)
                          (list 'quote
                            (LM:grsnap:snapsymbols
                              (atoi (cond ((getenv "AutoSnapSize")) ("5")))
                            )
                          )
                        )
                      )
                      (LM:OLE->ACI
                        (if (= 1 (getvar 'cvport))
                          (atoi (cond ((getenv "Layout AutoSnap Color")) ("117761")))
                          (atoi (cond ((getenv  "Model AutoSnap Color")) ("104193")))
                        )
                      )
                    )
                  )
                )
               '(cond ((car q)) (p))
              )
            )
          )

          ;; Object Snap for grread: Display Snap  -  Lee Mac
          ;; pnt - [lst] UCS point at which to display the symbol
          ;; lst - [lst] grvecs vector list
          ;; col - [int] ACI colour for displayed symbol
          ;; Returns nil

          (defun LM:grsnap:displaysnap ( pnt lst col / scl )
            (setq scl (/ (getvar 'viewsize) (cadr (getvar 'screensize))))
            (setq pnt (trans pnt 1 1))
            (grvecs (cons col (mapcar (function (lambda ( x ) (mapcar (function +) (mapcar (function *) x (list scl scl)) pnt))) lst))
              ;|
              (list
                (list 1.0 0.0 0.0 0.0)
                (list 0.0 1.0 0.0 0.0)
                (list 0.0 0.0 1.0 0.0)
                (list 0.0 0.0 0.0 1.0)
              ) ;;; This matrix is for presentation of vectors - start/end points should be supplied in DCS ; if you omit matrix - start/end points should be supplied in UCS
              |;
            )
          )

          ;; Object Snap for grread: Snap Symbols  -  Lee Mac
          ;; p - [int] Size of snap symbol in pixels
          ;; Returns: [lst] List of vector lists describing each Object Snap symbol

          (defun LM:grsnap:snapsymbols ( p / -p -q -r a c i l q r )
            (setq -p (- p) q (1+  p)
                  -q (- q) r (+ 2 p)
                  -r (- r) i (/ pi 6)
                   a 0.0
            )
            (repeat 12
              (setq l (cons (list (* r (cos a)) (* r (sin a))) l)
                    a (- a i)
              )
            )
            (setq c (apply 'append (mapcar 'list (cons (last l) l) l)))
            (list
              (list 0001
                (list -p -p) (list p -p) (list p -p) (list p p) (list p p) (list -p p) (list -p p) (list -p -p)
                (list -q -q) (list q -q) (list q -q) (list q q) (list q q) (list -q q) (list -q q) (list -q -q)
              )
              (list 0002
                (list -r -q) (list 0  r) (list 0  r) (list r -q)
                (list -p -p) (list p -p) (list p -p) (list 0  p) (list 0  p) (list -p -p)
                (list -q -q) (list q -q) (list q -q) (list 0  q) (list 0  q) (list -q -q)
              )
              (cons 0004 c)
              (vl-list* 0008 (list -r -r) (list r r) (list r -r) (list -r r) c)
              (list 0016
                (list p 0) (list 0 p) (list 0 p) (list -p 0) (list -p 0) (list 0 -p) (list 0 -p) (list p 0)
                (list q 0) (list 0 q) (list 0 q) (list -q 0) (list -q 0) (list 0 -q) (list 0 -q) (list q 0)
                (list r 0) (list 0 r) (list 0 r) (list -r 0) (list -r 0) (list 0 -r) (list 0 -r) (list r 0)
              )
              (list 0032
                (list  r r) (list -r -r) (list  r q) (list -q -r) (list  q r) (list -r -q)
                (list -r r) (list  r -r) (list -q r) (list  r -q) (list -r q) (list  q -r)
              )
              (list 0064
                '( 0  1) (list  0  p) (list  0  p) (list -p  p) (list -p  p) (list -p -1) (list -p -1) '( 0 -1)
                '( 0 -1) (list  0 -p) (list  0 -p) (list  p -p) (list  p -p) (list  p  1) (list  p  1) '( 0  1)
                '( 1  2) (list  1  q) (list  1  q) (list -q  q) (list -q  q) (list -q -2) (list -q -2) '(-1 -2)
                '(-1 -2) (list -1 -q) (list -1 -q) (list  q -q) (list  q -q) (list  q  2) (list  q  2) '( 1  2)
              )
              (list 0128
                (list (1+ -p) 0) '(0 0) '(0 0) (list 0 (1+ -p))
                (list (1+ -p) 1) '(1 1) '(1 1) (list 1 (1+ -p))
                (list -p q) (list -p -p) (list -p -p) (list q -p)
                (list -q q) (list -q -q) (list -q -q) (list q -q)
              )
              (vl-list* 256 (list -r r)  (list r r) (list -r (1+ r)) (list r (1+ r)) c)
              (list 0512
                (list -p -p) (list  p -p) (list -p  p) (list p p) (list -q -q) (list  q -q)
                (list  q -q) (list -q  q) (list -q  q) (list q q) (list  q  q) (list -q -q)
              )
              (list 2048
                (list   -p     -p) (list    p      p) (list   -p      p) (list    p     -p)
                (list (+ p 05) -p) (list (+ p 06) -p) (list (+ p 05) -q) (list (+ p 06) -q)
                (list (+ p 09) -p) (list (+ p 10) -p) (list (+ p 09) -q) (list (+ p 10) -q)
                (list (+ p 13) -p) (list (+ p 14) -p) (list (+ p 13) -q) (list (+ p 14) -q)
                (list -p -p) (list p -p) (list p -p) (list p p) (list p p) (list -p p) (list -p p) (list -p -p)
                (list -q -q) (list q -q) (list q -q) (list q q) (list q q) (list -q q) (list -q q) (list -q -q)
              )
              (list 8192 (list r 1) (list -r -q) (list r 0) (list -r -r) (list r q) (list -r -1) (list r r) (list -r 0))
            )
          )

          ;; Object Snap for grread: Parse Point  -  Lee Mac
          ;; bpt - [lst] Basepoint for relative point input, e.g. @5,5
          ;; str - [str] String representing point input
          ;; Returns: [lst] Point represented by the given string, else nil

          (defun LM:grsnap:parsepoint ( bpt str / str->lst lst )

            (defun str->lst ( str / pos )
              (if (setq pos (vl-string-position 44 str))
                (cons (substr str 1 pos) (str->lst (substr str (+ pos 2))))
                (list str)
              )
            )

            (if (wcmatch str "`@*")
                (setq str (substr str 2))
                (setq bpt (list 0.0 0.0 0.0))
            )
            (if
              (and
                (setq lst (mapcar (function distof) (str->lst str)))
                (vl-every (function numberp) lst)
                (< 1 (length lst) 4)
              )
              (mapcar (function +) bpt lst)
            )
          )

          ;; Object Snap for grread: Snap Mode  -  Lee Mac
          ;; str - [str] Object Snap modifier
          ;; Returns: [int] Object Snap bit code for the given modifier, else nil

          (defun LM:grsnap:snapmode ( str )
            (vl-some
              (function
                (lambda ( x )
                  (if (wcmatch (car x) (strcat (strcase str t) "*"))
                    (progn (setq ff t) (princ (cadr x)) (caddr x))
                  )
                )
              )
             '(
                ("endpoint"      " of " 0001)
                ("midpoint"      " of " 0002)
                ("center"        " of " 0004)
                ("node"          " of " 0008)
                ("quadrant"      " of " 0016)
                ("intersection"  " of " 0032)
                ("insert"        " of " 0064)
                ("perpendicular" " to " 0128)
                ("tangent"       " to " 0256)
                ("nearest"       " to " 0512)
                ("appint"        " of " 2048)
                ("parallel"      " to " 8192)
                ("none"          ""     16384)
              )
            )
          )

          ;; OLE -> ACI  -  Lee Mac
          ;; Args: c - [int] OLE Colour
          (defun LM:OLE->ACI ( c )
            (apply (function LM:RGB->ACI) (LM:OLE->RGB c))
          )

          ;; OLE -> RGB  -  Lee Mac
          ;; Args: c - [int] OLE Colour
          (defun LM:OLE->RGB ( c )
            (mapcar (function (lambda ( x ) (lsh (lsh (fix c) x) -24))) (list 24 16 8))
          )

          ;; RGB -> ACI  -  Lee Mac
          ;; Args: r,g,b - [int] Red, Green, Blue values
          (defun LM:RGB->ACI ( r g b / c o )
            (if (setq o (vla-getinterfaceobject (LM:acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
              (progn
                (setq c (vl-catch-all-apply (function (lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o)))))
                (vlax-release-object o)
                (if (vl-catch-all-error-p c)
                  (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
                  c
                )
              )
            )
          )

        )
      )
    ) ;;; end GrSnap-subs

    (GrSnap-subs)
    (setq ll (list 'LM:grsnap:snapfunction 'LM:grsnap:displaysnap 'LM:grsnap:snapsymbols 'LM:grsnap:parsepoint 'LM:grsnap:snapmode 'LM:OLE->ACI 'LM:OLE->RGB 'LM:RGB->ACI))
    (setq osf (LM:grsnap:snapfunction))
    (setq osm (getvar (quote osmode)))
    (if (equal 0 (getvar (quote undoctl)))
      (if command-s
        (command-s "_.undo" "_all")
        (vl-cmdf "_.undo" "_all")
      )
    )
    (if
      (or
        (not (equal 1 (logand 1 (getvar (quote undoctl)))))
        (equal 2 (logand 2 (getvar (quote undoctl))))
      )
      (if command-s
        (command-s "_.undo" "_control" "_all")
        (vl-cmdf "_.undo" "_control" "_all")
      )
    )
    (if (equal 4 (logand 4 (getvar (quote undoctl))))
      (if command-s
        (command-s "_.undo" "_auto" "_off")
        (vl-cmdf "_.undo" "_auto" "_off")
      )
    )
    (while (equal 8 (logand 8 (getvar (quote undoctl))))
      (if command-s
        (command-s "_.undo" "_end")
        (vl-cmdf "_.undo" "_end")
      )
    )
    (if command-s
      (command-s "_.undo" "_begin")
      (vl-cmdf "_.undo" "_begin")
    )
    (setq loop t)
    (while (and loop (setq grr (grread t 7 0)));  exit on ENTER or picked point
      (redraw)
      (setq loop
        (cond
          ;;=====================================================
          ((= 2 (car grr)) ; keyboard input
           (setq key (cadr grr))
           (cond
             ;;-------------------------------------------
             ((= key 13) ; ENTER- where done here
              (and ent (entdel ent))
              (princ "\nUser Quit.")
              nil ; exit loop
             )
             ;;-------------------------------------------
             ((member (chr key) '("I" "i")) ; Insert with OSNAP
               (vl-cmdf "_.move" ent "" "_non" lastpt)
               (while (= (logand (getvar "cmdactive") 1) 1)
                 (vl-cmdf "\\")
               )
               nil ; exit loop
             )
             ((member (chr key) '("L" "l")) ; Left or CCW
               (vl-cmdf "_.rotate" ent "" "_non" ip 90.0)
               t ; stay in loop
             )
             ((member (chr key) '("R" "r")) ; Right or CW
               (vl-cmdf "_.rotate" ent "" "_non" ip -90.0)
               t ; stay in loop
             )
             ;;-------------------------------------------
             ((princ "\nInvalid Keypress.") t)
           ) ; end cond
          )
          ;;=====================================================
          ((= 3 (car grr)) ; point picked, make final insertion
           (setq ip (osf (cadr grr) osm))
           nil ; exit
          )
          ;;=====================================================
          ((or (= 12 (car grr)) (= 5 (car grr))) ; point from mouse, update object
           (setq ip (osf (cadr grr) osm))
           (if (not lastpt) ; first time through
             (progn
               (setq lastpt ip)
               (vl-cmdf "_.-insert" bname "_S" 1.0 "_R" 0.0 "_non" ip)
               (setq ent (entlast))
             )
           )
           (if (> (distance ip lastpt) 0.00001)
             (vl-cmdf "_.move" ent "" "_non" lastpt "_non" ip)
           )
           (setq lastpt ip)
          )
          ((and (= (car grr) 11) (= (cadr grr) 1000)) ; shift+right click
           (progn
             (initdia)
             (if command-s
               (command-s "_.osnap")
               (vl-cmdf "_.osnap")
             )
             (setq osm (getvar (quote osmode)))
             t   ; stay in loop
           )
          )
        )   ; end cond
      )   ; end (setq loop)
      ;;=====================================================
    )   ; while
    (initget "Yes No")
    (setq ch (cond ( (getkword "\nDo you want to explode and purge inserted block [Yes/No]  : ") ) ("Yes")))
    (if (= ch "Yes")
      (progn
        (vl-cmdf "_.explode" (entlast))
        (while (< 0 (getvar (quote cmdactive)))
          (vl-cmdf "")
        )
        (vl-cmdf "_.-purge" "_b" bname "_n")
      )
    )
  )

  (setq doc (vla-get-activedocument (LM:acapp)))
  (setq spc (vla-get-block (setq alo (vla-get-activelayout doc))))
  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (setq ape (getvar (quote aperture)))
  (setvar (quote aperture) 10)
  (setq pdm (getvar (quote pdmode)))
  (setvar (quote pdmode) 35)
  (if (equal 0 (getvar (quote worlducs)))
    (progn
      (if command-s
        (command-s "_.ucs" "_w")
        (vl-cmdf "_.ucs" "_w")
      )
      (setq uf t)
    )
  )
  (if
    (and
      (setq s (ssget "_:L"))
      (not (initget 1))
      (setq bp (getpoint "\nPick or specify base point : "))
    )
    (progn
      (vl-cmdf "_.copybase" "_non" bp s "")
      (vl-cmdf "_.pasteblock" "_non" bp)
      (if (vl-catch-all-error-p (setq blkname (vl-catch-all-apply (function effectivename) (list (entlast)))))
        (setq blkname (cdr (assoc 2 (entget (entlast)))))
      )
      (entdel (entlast))
      (ins+rot_L-R+osnap blkname)
    )
  )
  (*error* nil)
)

Regards, M.R.

Marko Ribar, d.i.a. (graduated engineer of architecture)

le-tan-phuc · ‎05-21-2024

D

Thank you for your kindness M.R. !
but the purpose I want is shown in the this Gif image (but instead of selecting points and then rotating blocks each time, I want to rotate blocks first (rotate 90 degree by R key) and then choose points to place them).

Now i'm using Insert Block table (as shown in the Gif image), and I think it's fine !
But I still want to thank you again !

Community

Need help to modify code &quot;rotate block for preview prior pick point to insert block&quot;