Rotation and Scale factor for Block array

[tnvsb]

Dear Helpers,

 

I got a code from kent cooper from Autodesk lisp forum, that's working fine. I need a small change in below code that it should ask for block rotation and block Scale. Please change the code as per my requirements.

(vl-load-com)
(defun C:ABR ; = Array Block in Rectangle(s)
  (/ *error* ABRia doc svnames svvals P1 rectss n P3)
  (defun *error* (errmsg)
    (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
      (princ (strcat "\nError: " errmsg))
    ); if
    (if ucschanged (command-s "_.ucs" "_previous"))
      ; [change to (command ...  if Acad version predates (command-s) function]
    (mapcar 'setvar svnames svvals); reset System Variables
    (vla-endundomark doc)
    (princ)
  ); defun - *error*
  (defun ABRia (/ delta LL NX NY colsp rowsp); = ABR Insert & Array
    (setq
      delta (mapcar 'abs (mapcar '- P3 P1)); differences in XYZ list
      LL (mapcar 'min P1 P3)
        ; Lower Left regardless of pick order or Pline start or direction
      colsp (/ (car delta) cols)
      rowsp (/ (cadr delta) rows)
    ); setq
    (command
      "_.insert" blk "_none" (mapcar '+ LL (list (/ colsp 2) (/ rowsp 2))) "" "" ""
      "_.array" "_last" "" "_r" rows cols rowsp colsp
    ); command
  ); defun -- ABRia
  (vla-startundomark (setq doc (vla-get-activedocument (vlax-get-acad-object))))
  (setq ; System Variable saving/resetting without separate variables for each:
    svnames '(cmdecho ucsfollow osmode blipmode)
    svvals (mapcar 'getvar svnames)
    blk (cdr (assoc 2 (entget (car (entsel "\n Select Block")))))
    rows (getint "\nNumber of columns (|||): ")
    cols (getint "\nNumber of rows (---): ")
  ); setq
  (mapcar 'setvar svnames '(0 0)); turn off command echoing, UCS follow
  (initget "Select"); allows S as input to (getpoint) function, instead of point pick
  (setq P1 (getpoint "\nFirst Corner of ortho-rectangular area for Blocks, or [Select]: "))
    ; [if in non-World UCS, returns in current UCS coordinates, not in WCS]
  (if (= P1 "Select"); chose that option
    (progn ; then
      (prompt "\nTo Array Blocks in Rectangular Polyline(s),")
      (if (setq rectss (ssget '((0 . "LWPOLYLINE") (90 . 4) (-4 . "&") (70 . 1))))
        ; multipleselection -- only 4-vertex closed [does not check for rectangularity]
        (progn ; then
          (mapcar 'setvar svnames '(0 0 0 0)); also turn off Osnap, blips
          (repeat (setq n (sslength rectss)); step through selection
            (setq rect (ssname rectss (setq n (1- n))))
            (command "_.ucs" "_object" rect)
            (setq
              ucschanged T ; marker for resetting in *error*
              P1 (trans (vlax-curve-getPointAtParam rect 0) 0 1); starting vertex
              P3 (trans (vlax-curve-getPointAtParam rect 2) 0 1); third vertex [opposite corner]
            ); setq
            (ABRia); run the subroutine to MINSERT
            (command "_.ucs" "_previous")
            (setq ucschanged nil); [turn off marker]
          ); repeat
        ); progn
        (prompt "\nNo closed 4-vertex Polyline(s) selected."); else
      ); if
    ); progn
    (progn ; else [picked a point]
      (setq P3 (getcorner P1 "\nOpposite Corner: "))
      (mapcar 'setvar svnames '(0 0 0 0)); also turn off Osnap, blips
      (ABRia); run the subroutine to MINSERT
    ); progn
  ); if
  (mapcar 'setvar svnames svvals); reset System Variables
  (vla-endundomark doc)
  (princ)
); defun -- C:ABR

Regards,

T.Brahmanandam

[Emmanuel Delay]

Try this

 

(vl-load-com)
(defun C:ABR ; = Array Block in Rectangle(s)
  (/ *error* ABRia doc svnames svvals P1 rectss n P3 blk scl rot)
  (defun *error* (errmsg)
    (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
      (princ (strcat "\nError: " errmsg))
    ); if?
    (if ucschanged (command-s "_.ucs" "_previous"))
      ; [change to command ...  if Acad version predates (command-s) function]
    (mapcar 'setvar svnames svvals); reset System Variables
    (vla-endundomark doc)
    (princ)
  ); defun - *error*
  (defun ABRia (/ delta LL NX NY colsp rowsp ); = ABR Insert & Array
    (setq
      delta (mapcar 'abs (mapcar '- P3 P1)); differences in XYZ list
      LL (mapcar 'min P1 P3)
        ; Lower Left regardless of pick order or Pline start or direction
      colsp (/ (car delta) cols)
      rowsp (/ (cadr delta) rows)
    ); setq
    (command
      "_.insert" blk "_none" (mapcar '+ LL (list (/ colsp 2) (/ rowsp 2))) scl scl rot
      "_.array" "_last" "" "_r" rows cols rowsp colsp
    ); command
  ); defun -- ABRia
  (vla-startundomark (setq doc (vla-get-activedocument (vlax-get-acad-object))))
  (setq ; System Variable saving/resetting without separate variables for each:
    svnames '(cmdecho ucsfollow osmode blipmode)
    svvals (mapcar 'getvar svnames)
    blk (cdr (assoc 2 (entget (car (entsel "\n Select Block")))))
    rows (getint "\nNumber of columns (|||): ")
    cols (getint "\nNumber of rows (---): ")
    scl (getreal  "\nScale: ")
    rot (getreal  "\nRotation angle: ")
  ); setq
  (mapcar 'setvar svnames '(0 0)); turn off command echoing, UCS follow
  (initget "Select"); allows S as input to (getpoint) function, instead of point pick
  (setq P1 (getpoint "\nFirst Corner of ortho-rectangular area for Blocks, or [Select]: "))
    ; [if in non-World UCS, returns in current UCS coordinates, not in WCS]
  (if (= P1 "Select"); chose that option
    (progn ; then
      (prompt "\nTo Array Blocks in Rectangular Polyline(s),")
      (if (setq rectss (ssget '((0 . "LWPOLYLINE") (90 . 4) (-4 . "&") (70 . 1))))
        ; multipleselection -- only 4-vertex closed [does not check for rectangularity]
        (progn ; then
          (mapcar 'setvar svnames '(0 0 0 0)); also turn off Osnap, blips
          (repeat (setq n (sslength rectss)); step through selection
            (setq rect (ssname rectss (setq n (1- n))))
            (command "_.ucs" "_object" rect)
            (setq
              ucschanged T ; marker for resetting in *error*
              P1 (trans (vlax-curve-getPointAtParam rect 0) 0 1); starting vertex
              P3 (trans (vlax-curve-getPointAtParam rect 2) 0 1); third vertex [opposite corner]
            ); setq
            (ABRia); run the subroutine to MINSERT
            (command "_.ucs" "_previous")
            (setq ucschanged nil); [turn off marker]
          ); repeat
        ); progn
        (prompt "\nNo closed 4-vertex Polyline(s) selected."); else
      ); if
    ); progn
    (progn ; else [picked a point]
      (setq P3 (getcorner P1 "\nOpposite Corner: "))
      (mapcar 'setvar svnames '(0 0 0 0)); also turn off Osnap, blips
      (ABRia); run the subroutine to MINSERT
    ); progn
  ); if
  (mapcar 'setvar svnames svvals); reset System Variables
  (vla-endundomark doc)
  (princ)
); defun -- C:ABR

Edited October 9, 2018 by Emmanuel Delay

[tnvsb]

Thank you so muh Sir.