Topic: block x y independent scale dynamicly

[dussla]

hello freind
i have a problem

i have  some blocks
i would like to   change  x  y scale  independently

i know scale  command , 

but  i would like to scale  x y  with realtime   
is there good idea?

[Lee Mac]

How about using a dynamic block Linear Parameter associated with a Stretch Action, e.g.:

[dussla]

i  have to use entire block  stretch ,   block edit  modify 1 objects only
my work block is old block style ,   that is not dynamic block
so  i can't see  liner parameter in my work cad ( autocad2012)
~~

[Faster]

hello freind
i have a problem

i have  some blocks
i would like to   change  x  y scale  independently

i know scale  command , 

but  i would like to scale  x y  with realtime   
is there good idea?

Code: [Select]

(defun c:BlkDynScale  (/ BLKREF EL BASE LOOP GR W H W1 H1 obj)
  (if
    (and
      (setq blkref (car (entsel "\nSelect a insert :")))
      (= "INSERT" (cdr (assoc 0 (entget blkref))))
      )
     (progn
       (setq el   (entget blkref)
     base (trans (cdr (assoc 10 el)) 0 1))
       (sssetfirst nil (ssadd blkref))
       (vla-GetBoundingBox
(setq obj (vlax-ename->vla-object blkref))
'll
'ur)
       (mapcar
'set
(list 'w 'h)
(apply 'mapcar
(cons '- (mapcar 'vlax-safearray->list (list ur ll)))))
       (setq loop t xs (vla-get-XScaleFactor obj) ys (vla-get-YScaleFactor obj))
       (while loop
(setq gr (grread t 15))
(cond
   ((= 5 (car gr))
    (mapcar 'set
    (list 'w1 'h1)
    (mapcar '- (cadr gr) base))
    (setq xscale (* xs (/ w1 w))
  yscale (* ys (/ h1 h))
  )
    (redraw)
    (grdraw base (cadr gr) 7 1)
    (princ (strcat "\rXScle = " (rtos xscale 2 4) "  YScale = " (rtos yscale 2 4) "        "))
    (vla-put-XScaleFactor obj xscale)
    (vla-put-YScaleFactor obj yscale)
    (vla-update obj)

    )
   ((= 3 (car gr))
    (setq loop nil)
    (redraw)
    (sssetfirst  (ssadd blkref) nil)
    (mapcar 'set
    (list 'w1 'h1)
    (mapcar '- (cadr gr) base))
    (setq xscale (* xs (/ w1 w))
  yscale (* ys (/ h1 h))
  )
    (princ (strcat "\rXScle = " (rtos xscale 2 4) "  YScale = " (rtos yscale 2 4) "        "))
    (vla-put-XScaleFactor obj xscale)
    (vla-put-YScaleFactor obj yscale)
    (vla-update obj)
    )
   )
)
       )
     )
  (princ)
  )

[dussla]

good , thank you
but very  slow  ,  can you interval time ?

or   with getpoint

[Tharwat]

Try this piece of code .

Code - Auto/Visual Lisp: [Select]

1. (defun c:Test (/ ss x y i sn dxfs)
2. ;;;;;=== Tharwat 24. Aug. 2012 ===;;;;;
3.   (if
4.     (and (setq ss (ssget "_:L" '((0 . "INSERT"))))
5.          (setq x (getdist "\n Specify X factor scale :"))
6.          (setq y (getdist "\n Specify Y factor scale :"))
7.     )
8.      (repeat (setq i (sslength ss))
9.        (setq sn (ssname ss (setq i (1- i))))
10.        (mapcar
11.          (function (lambda (x)
12.                      (if (member (car x) '(43 410 62 8 10 2 0))
13.                        (setq dxfs (cons x dxfs))
14.                      )
15.                    )
16.          )
17.          (entget sn)
18.        )
19.        (if (entmakex
20.              (append (reverse dxfs) (list (cons 41 x) (cons 42 y)))
21.            )
22.          (entdel sn)
23.        )
24.        (setq dxfs nil)
25.      )
26.   )
27.   (princ)
28. )
29.  
30.  

[mkweaver]

Can you insert it with the "Specify opposite corner" option?  (You have to use the command line to access this one).

I have done this before where my block was one unit square with the insertion point at the lower left corner. This allowed me to specify the opposite corner and get the varying x and y scales that I needed.

[myloveflyer]

Code: [Select]

(defun C:XSCALE(/ bp ss xscal yscal entL)

  (defun errexit (s)
    (princ "\nError:  ")
    (princ s)
    (restore)
  )

  (defun restore ()
    (setvar "CMDECHO" (car oldvar))
    (setq *error* olderr)
    (princ)
  )
 
(defun MAKEUNBLOCK (ss ip / tmp errexit mbx BLAYER)

  (setq T (not nil))
  (setq olderr  *error*
        *error* errexit
  )
  (setq oldvar
    (list
      (getvar "CMDECHO")
    )
  )
  (setvar "CMDECHO" 0)
  (terpri)
  (if BLAYER 
    (command "._LAYER"
      (if (tblsearch "LAYER" BLAYER) "_S" "_M")
      BLAYER
      ""
    )
  )
  (if (and ip ss)
    (progn
      (entmake (list
        (cons '0 "BLOCK")
        (cons '2 "*U")
        (cons '70 1)
        (cons '10 ip)
      ))
      (setq cnt (sslength ss))
      (while (>= (setq cnt (1- cnt)) 0)
        (setq tmp (ssname ss cnt))
        (entmake (setq el (entget tmp)))
        (if (> (cdr (assoc 66 el)) 0)
          (while
            (/= "SEQEND"
              (cdr
                (assoc 0
                  (entmake (setq el (entget (entnext (cdr (assoc -1 el))))))
                )
              )
            )
          )
        )
        (entdel tmp)
      )
      (setq tmp (entmake (list (cons '0 "ENDBLK"))))
      (entmake (list
        (cons '0 "INSERT")
        (cons '2 tmp)
        (cons '10 ip)
      ))
    )
  ) 
  (restore)
)

  (setq ss (ssget)) ;;;You can add the scaling type
  (if ss
    (progn
      (setvar "cmdecho" 0)
      (setq bp (getpoint "Scaling reference point (<0,0,0>): "))
      (if (not bp) (setq bp (list 0 0 0)))
      (setq xscal (getreal "X scale <1>: "))
      (if (not xscal) (setq xscal 1))
      (setq yscal (getreal "Y scale <1>: "))
      (if (not yscal) (setq yscal 1))
      (MAKEUNBLOCK ss bp)
      (setq entL (entget (entLast))
  entL (subst (cons 41 xscal) (assoc 41 entL) entL)
  entL (subst (cons 42 yscal) (assoc 42 entL) entL)
      )
      (entmod entL)
      (command "_explode" "l" "")
    )
  )
  (princ )

[chlh_jd]

Nice routine , Faster
If add osnap for grread , it would be perfect .

[chlh_jd]

according Faster's routine , I add osnap function .
about Osmark function you can see http://www.theswamp.org/index.php?topic=12813.0

Code: [Select]

(defun c:BlkDynscale
       (/ f1 f2 BLKREF EL BASE LOOP GR pt W H W1 H1 obj0 obj _err)
  ;; block dynamicly scale
  ;; by Faster
  ;; From http://www.theswamp.org/index.php?topic=42599.0
  ;; Edited by GSLS(SS) 2012-9-5
  ;;     ---- ADD Osnap function
  (setq _err *error*)
 (defun *error* (msg)
    (command)
    (command)
    (if (or (= msg "Function cancelled")
    (= msg "quit / exit abort")
)
      (princ msg)
      (princ (strcat "\n错误: " msg))
    )
    (or (vlax-erased-p obj) (vla-delete obj))
    (sssetfirst (ssadd blkref) nil)
    (redraw)
    (setq *error* _err)
    (princ)
    ) 
  (defun f1  (/ ig lst mid m)
    (or (vlax-erased-p obj) (vla-delete obj))
    (redraw)
    (setq pt (osnap (cadr gr)
    "_end,_mid,_cen,_nod,_qua,_int,_tan,_per,_nea"))
    (if pt
      (progn
(setq ig  T
      lst (list "_end" "_mid" "_cen" "_nod" "_qua" "_int" "_tan"
"_per" "_nea"))
(while (and ig lst)
  (setq mid (car lst)
lst (cdr lst)
)
  (if (equal pt (osnap (cadr gr) mid))
    (setq m  mid
  ig nil
  )
    )
  )
(if m
  (osMark (list pt m (cadr gr)))
  )
)
      )
    (or pt (setq pt (cadr gr)))
    )
  (defun f2  ()
    (mapcar (function set)
    (list (quote w1) (quote h1))
    (mapcar (function -) pt base))
    (if (or (zerop w1) (zerop h1))
      nil
      (progn
(setq xscale (* (abs xs) (/ w1 w))
      yscale (* (abs ys) (/ h1 h))
      )
(grdraw base pt 7 1)
(princ (strcat "\rXScale = "
       (rtos xscale 2 4)
       "  YScale = "
       (rtos yscale 2 4)
       "        "))
(setq obj (vla-copy obj0))
(vla-put-XScaleFactor obj xscale)
(vla-put-YScaleFactor obj yscale)
(vla-update obj)
)))
  (if
    (and
      (setq blkref (car (entsel "\nSelect a insert :")))
      (= "INSERT" (cdr (assoc 0 (entget blkref))))
      )
     (progn
       (setq el   (entget blkref)
     base (trans (cdr (assoc 10 el)) 0 1))
       (sssetfirst nil (ssadd blkref))
       (setq obj0 (vlax-ename->vla-object blkref))
       (setq obj (vla-copy obj0))
       (vla-GetBoundingBox
obj
(quote ll)
(quote ur))
       (mapcar
(function set)
(list (quote w) (quote h))
(apply
   (function mapcar)
   (cons
     (function -)
     (mapcar (function vlax-safearray->list) (list ur ll)))))
       (setq loop t
     xs   (vla-get-XScaleFactor obj)
     ys   (vla-get-YScaleFactor obj))
       (while (and (/= 25 (car (setq gr (grread T 1 1))))
   (/= (car gr) 11)
   (/= (car gr) 2)
   loop)
(cond
   ((and (= 5 (car gr)) (f1))
    (f2)
    )
   ((and (= 3 (car gr)) (f1))
    (setq loop nil)
    (redraw)
    (sssetfirst (ssadd blkref) nil)
    (f2)
    (vla-put-XScaleFactor obj0 xscale)
    (vla-put-YScaleFactor obj0 yscale)
    (vla-update obj0)
    (vla-delete obj)
    )
   )
)
       )
     )
  (redraw)
  (setq *error* _err) 
  (princ)
  )
(princ "\nDynamicly block Scale Routine written by Faster ,Edited by GSLS(SS) 2012-9-5，command : BlkDynScale .")
(princ)


[Hugo]

Get an error message

Bekomme eine Fehlermeldung

Command: BLKDYNSCALE
Select a insert :*Cancel*
Command:
Command:
??: no function definition: OSMARK

[Lee Mac]

Why not simply:

Code: [Select]

(defun c:bs ( / e1 e2 l1 l2 )
    (if (and (setq e1 (car (entsel "\nSelect Block: ")))
             (= "INSERT" (cdr (assoc 0 (setq l1 (entget e1)))))
        )
        (progn
            (setq e2 (entlast))
            (entdel e1)
            (vl-catch-all-apply 'vl-cmdf
                (list "_.-insert"
                    (cdr (assoc 02 l1)) "_R" (angtos (cdr (assoc 50 l1))) "_non"
                    (cdr (assoc 10 l1)) "_C" "\\"
                )
            )
            (entdel e1)
            (if (and (not (eq e2 (setq e2 (entlast))))
                     (= "INSERT" (cdr (assoc 0 (setq l2 (entget e2)))))
                )
                (progn
                    (foreach x '(41 42 43) (setq l1 (subst (assoc x l2) (assoc x l1) l1)))
                    (entmod l1)
                    (entdel e2)
                )
            )
        )
    )
    (princ)
)

[Hugo]

for me it does not work

bei mir funktioniert das nicht

[Lee Mac]

for me it does not work

The block definition of the selected block must permit non-uniform scaling, perhaps this is the cause?

[Hugo]

Block is set correctly when scaling is not hacking

Block ist richtig eingestellt bei Skalierung kein Hacken

Danke

[Hugo]

1x1 block must be drawn then it works

Block muss 1x1 gezeichnet sein dann funktioniert es

[chlh_jd]

Get an error message
Bekomme eine Fehlermeldung
Command: BLKDYNSCALE
Select a insert :*Cancel*
Command:
Command:
??: no function definition: OSMARK

See the link http://www.theswamp.org/index.php?topic=12813.0

[chlh_jd]

Why not simply:

Code: [Select]

(defun c:bs ( / e1 e2 l1 l2 )
    (if (and (setq e1 (car (entsel "\nSelect Block: ")))
             (= "INSERT" (cdr (assoc 0 (setq l1 (entget e1)))))
      ....
    )
    (princ)
)

Hi , Lee Mac .
Great demo , However It can't run correct in my ACAD2011 for 64Bit WIN7 SYS

[Lee Mac]

Sorry, yes the block must be 1x1 or smaller in dimension 

[ribarm]

Sorry, yes the block must be 1x1 or smaller in dimension 

AutoCAD can't scale independently drawing units... Anno scales are there just for wasting time on presentations... 

[ribarm]

Here is my modification of Lee's code... It does thing with blocks that are not 1X1 units, but with some various dimensions of block - only thing after this routine, block scaling factors remain the same xscf=1.0 yscf=1.0 zscf=1.0, but dimensions are changed accordingly to desired picked corner point... Works also for rotated block...

Code - Auto/Visual Lisp: [Select]

1. ;; Doug C. Broad, Jr.
2. ;; can be used with vla-transformby to
3. ;; transform objects from the UCS to the WCS
4. (defun UCS2WCSMatrix ()
5.   (vlax-tmatrix
6.     (append
7.       (mapcar
8.              '(lambda (vector origin)
9.               (append (trans vector 1 0 t) (list origin))
10.             )
11.             (list '(1 0 0) '(0 1 0) '(0 0 1))
12.             (trans '(0 0 0) 0 1)
13.       )
14.       (list '(0 0 0 1))
15.     )
16.   )
17. )
18. ;; transform objects from the WCS to the UCS
19. (defun WCS2UCSMatrix ()
20.   (vlax-tmatrix
21.     (append
22.       (mapcar
23.              '(lambda (vector origin)
24.               (append (trans vector 0 1 t) (list origin))
25.             )
26.             (list '(1 0 0) '(0 1 0) '(0 0 1))
27.             (trans '(0 0 0) 1 0)
28.       )
29.       (list '(0 0 0 1))
30.     )
31.   )
32. )
33.  
34. (defun boundbox ( blk / ent minpt maxpt )
35.   (vl-load-com)
36.   (if (eq (type blk) 'ENAME) (setq ent (vlax-ename->vla-object blk)))
37.   (if blk
38.     (progn
39.       (vl-cmdf "_.UCS" "e" blk)
40.       (vla-TransformBy ent (UCS2WCSMatrix))
41.       (vla-getboundingbox ent 'minpoint 'maxpoint)
42.       (vla-TransformBy ent (WCS2UCSMatrix))
43.       (setq minpt (vlax-safearray->list minpoint))
44.       (setq maxpt (vlax-safearray->list maxpoint))
45.       (vl-cmdf "_.UCS" "p")
46.     )
47.   )
48.   (list minpt maxpt)
49. )
50.  
51. (defun scblk2unitblk ( blk / ent Xscf Yscf Zscf minpt maxpt dp )
52.   (vl-load-com)
53.   (if (eq (type blk) 'ENAME) (setq ent (vlax-ename->vla-object blk)))
54.   (setq Xscf (/ 1.0 (* (cos (angle (setq minpt (list (caar (boundbox blk)) (cadar (boundbox blk)))) (setq maxpt (list (caadr (boundbox blk)) (cadadr (boundbox blk)))))) (setq dp (distance minpt maxpt)))))
55.   (setq Yscf (/ 1.0 (* (sin (angle minpt maxpt)) dp)))
56.   (setq Zscf (/ 1.0 (if (eq (- (caddr (cadr (boundbox blk))) (caddar (boundbox blk))) 0.0) 1.0 (- (caddr (cadr (boundbox blk))) (caddar (boundbox blk))))))
57.   (vla-put-XScaleFactor ent Xscf)
58.   (vla-put-YScaleFactor ent Yscf)
59.   (vla-put-ZScaleFactor ent Zscf)
60.   (vla-put-Rotation ent 0.0)
61. )
62. ;|
63. (defun scunitblk2blk ( blk / ent Xscf Yscf Zscf minpt maxpt dp )
64.   (vl-load-com)
65.   (if (eq (type blk) 'ENAME) (setq ent (vlax-ename->vla-object blk)))
66.   (setq Xscf (* (cos (angle (setq minpt (list (caar (boundbox blk)) (cadar (boundbox blk)))) (setq maxpt (list (caadr (boundbox blk)) (cadadr (boundbox blk)))))) (setq dp (distance minpt maxpt))))
67.   (setq Yscf (* (sin (angle minpt maxpt)) dp))
68.   (setq Zscf (if (eq (- (caddr (cadr (boundbox blk))) (caddar (boundbox blk))) 0.0) 1.0 (- (caddr (cadr (boundbox blk))) (caddar (boundbox blk)))))
69.   (vla-put-XScaleFactor ent Xscf)
70.   (vla-put-YScaleFactor ent Yscf)
71.   (vla-put-ZScaleFactor ent Zscf)
72.   (vla-put-Rotation ent 0.0)
73. )
74. |;
75. (defun c:bs ( / e1 e2 e3ss l1 l2 )
76.     (vl-cmdf "_.UCS" "w")
77.     (if (and (setq e1 (car (entsel "\nSelect Block: ")))
78.              (= "INSERT" (cdr (assoc 0 (setq l1 (entget e1)))))
79.         )
80.         (progn
81.             (setq e2 (entlast))
82.             (vl-cmdf "_.UCS" "e" e1)
83.             (vl-cmdf "_.UCS" "w")
84.             (scblk2unitblk e1)
85.             (vl-cmdf "_.explode" e1)
86.             (setq e3ss (ssget "_P"))
87.             (vl-cmdf "_.-block" (cdr (assoc 02 l1)) "_Y" "_non" (cdr (assoc 10 l1)) e3ss "")
88.             (vl-cmdf "_.UCS" "p")
89.             (vl-catch-all-apply 'vl-cmdf
90.                 (list "_.-insert"
91.                     (cdr (assoc 02 l1)) "_R" "0.0" "_non"
92.                     '(0.0 0.0 0.0) "_C" "\\"
93.                 )
94.             )
95.             (if (and (not (eq e2 (setq e2 (entlast))))
96.                      (= "INSERT" (cdr (assoc 0 (setq l2 (entget e2)))))
97.                 )
98.                 (progn
99.                     (vl-cmdf "_.UCS" "w")
100.                     (vl-cmdf "_.rotate" e2 "" (cdr (assoc 10 l1)) (- (cvunit (cdr (assoc 50 l1)) "radians" "degrees")))
101.                     (vl-cmdf "_.explode" e2)
102.                     (entdel e2)
103.                     (setq e3ss (ssget "_P"))
104.                     (entdel e2)
105.                     (vl-cmdf "_.-block" (cdr (assoc 02 l1)) "_Y" (cdr (assoc 10 l1)) e3ss "")
106.                     (vl-cmdf "_.UCS" "p")
107.                     (vl-cmdf "_.-insert" (cdr (assoc 02 l1)) "_R" "0.0" "_non" '(0.0 0.0 0.0) "1.0" "")
108.                     (entmod (subst (assoc 8 l1) (assoc 8 (entget (entlast))) (entget (entlast))))
109.                     (if (assoc 62 l1) (entmod (append (list (assoc 62 l1)) (entget (entlast)))))
110.                     (entupd (entlast))
111.                 )
112.             )
113.         )
114.         (alert "\nPick block - picked object wasn't block entity")
115.     )
116.     (vl-cmdf "_.UCS" "p")
117.     (vl-cmdf "_.UCS" "p")
118.     (princ)
119. )
120.  

Regards, M.R.

[Hugo]

Thanks for the Lisp

But if the block is not drawn 1x1 is the same as happened in Lee's Lisp.
Does not exist.


Danke für das Lisp

Aber wenn der block nicht 1x1 gezeichnet ist passiert das gleich wie bei Lee seinen Lisp.
Funktioniert leider auch nicht.

[ribarm]

I've tested it on my netbook A2009 and it works... Please, if you can't get result with my - Lee's modified code on other AutoCAD versions with some other configurations, inform me... Here it seems to work OK... Note that your block must be with base point on lower left corner of its bounding box...

Please, respond...

[Hugo]

Thank you now it works perfectly.
Do not know why but it works.
Thank you

Danke jetzt funktioniert es perfekt.
Weiß zwar nicht warum aber es läuft.
Danke

[ribarm]

For A2008 and lower (not tested) - the trick is in line (vl-cmdf "_.explode" e1) - A2009 and higher and (vl-cmdf "_.explode" e1 "") - A2008 :

Code - Auto/Visual Lisp: [Select]

1. ;; Doug C. Broad, Jr.
2. ;; can be used with vla-transformby to
3. ;; transform objects from the UCS to the WCS
4. (defun UCS2WCSMatrix ()
5.   (vlax-tmatrix
6.     (append
7.       (mapcar
8.              '(lambda (vector origin)
9.               (append (trans vector 1 0 t) (list origin))
10.             )
11.             (list '(1 0 0) '(0 1 0) '(0 0 1))
12.             (trans '(0 0 0) 0 1)
13.       )
14.       (list '(0 0 0 1))
15.     )
16.   )
17. )
18. ;; transform objects from the WCS to the UCS
19. (defun WCS2UCSMatrix ()
20.   (vlax-tmatrix
21.     (append
22.       (mapcar
23.              '(lambda (vector origin)
24.               (append (trans vector 0 1 t) (list origin))
25.             )
26.             (list '(1 0 0) '(0 1 0) '(0 0 1))
27.             (trans '(0 0 0) 1 0)
28.       )
29.       (list '(0 0 0 1))
30.     )
31.   )
32. )
33.  
34. (defun boundbox ( blk / ent minpt maxpt )
35.   (vl-load-com)
36.   (if (eq (type blk) 'ENAME) (setq ent (vlax-ename->vla-object blk)))
37.   (if blk
38.     (progn
39.       (vl-cmdf "_.UCS" "e" blk)
40.       (vla-TransformBy ent (UCS2WCSMatrix))
41.       (vla-getboundingbox ent 'minpoint 'maxpoint)
42.       (vla-TransformBy ent (WCS2UCSMatrix))
43.       (setq minpt (vlax-safearray->list minpoint))
44.       (setq maxpt (vlax-safearray->list maxpoint))
45.       (vl-cmdf "_.UCS" "p")
46.     )
47.   )
48.   (list minpt maxpt)
49. )
50.  
51. (defun scblk2unitblk ( blk / ent Xscf Yscf Zscf minpt maxpt dp )
52.   (vl-load-com)
53.   (if (eq (type blk) 'ENAME) (setq ent (vlax-ename->vla-object blk)))
54.   (setq Xscf (/ 1.0 (* (cos (angle (setq minpt (list (caar (boundbox blk)) (cadar (boundbox blk)))) (setq maxpt (list (caadr (boundbox blk)) (cadadr (boundbox blk)))))) (setq dp (distance minpt maxpt)))))
55.   (setq Yscf (/ 1.0 (* (sin (angle minpt maxpt)) dp)))
56.   (setq Zscf (/ 1.0 (if (eq (- (caddr (cadr (boundbox blk))) (caddar (boundbox blk))) 0.0) 1.0 (- (caddr (cadr (boundbox blk))) (caddar (boundbox blk))))))
57.   (vla-put-XScaleFactor ent Xscf)
58.   (vla-put-YScaleFactor ent Yscf)
59.   (vla-put-ZScaleFactor ent Zscf)
60.   (vla-put-Rotation ent 0.0)
61. )
62. ;|
63. (defun scunitblk2blk ( blk / ent Xscf Yscf Zscf minpt maxpt dp )
64.   (vl-load-com)
65.   (if (eq (type blk) 'ENAME) (setq ent (vlax-ename->vla-object blk)))
66.   (setq Xscf (* (cos (angle (setq minpt (list (caar (boundbox blk)) (cadar (boundbox blk)))) (setq maxpt (list (caadr (boundbox blk)) (cadadr (boundbox blk)))))) (setq dp (distance minpt maxpt))))
67.   (setq Yscf (* (sin (angle minpt maxpt)) dp))
68.   (setq Zscf (if (eq (- (caddr (cadr (boundbox blk))) (caddar (boundbox blk))) 0.0) 1.0 (- (caddr (cadr (boundbox blk))) (caddar (boundbox blk)))))
69.   (vla-put-XScaleFactor ent Xscf)
70.   (vla-put-YScaleFactor ent Yscf)
71.   (vla-put-ZScaleFactor ent Zscf)
72.   (vla-put-Rotation ent 0.0)
73. )
74. |;
75. (defun c:bs ( / e1 e2 e3ss l1 l2 )
76.     (vl-cmdf "_.UCS" "w")
77.     (if (and (setq e1 (car (entsel "\nSelect Block: ")))
78.              (= "INSERT" (cdr (assoc 0 (setq l1 (entget e1)))))
79.         )
80.         (progn
81.             (setq e2 (entlast))
82.             (vl-cmdf "_.UCS" "e" e1)
83.             (vl-cmdf "_.UCS" "w")
84.             (scblk2unitblk e1)
85.             (vl-cmdf "_.explode" e1 "")
86.             (setq e3ss (ssget "_P"))
87.             (vl-cmdf "_.-block" (cdr (assoc 02 l1)) "_Y" "_non" (cdr (assoc 10 l1)) e3ss "")
88.             (vl-cmdf "_.UCS" "p")
89.             (vl-catch-all-apply 'vl-cmdf
90.                 (list "_.-insert"
91.                     (cdr (assoc 02 l1)) "_R" "0.0" "_non"
92.                     '(0.0 0.0 0.0) "_C" "\\"
93.                 )
94.             )
95.             (if (and (not (eq e2 (setq e2 (entlast))))
96.                      (= "INSERT" (cdr (assoc 0 (setq l2 (entget e2)))))
97.                 )
98.                 (progn
99.                     (vl-cmdf "_.UCS" "w")
100.                     (vl-cmdf "_.rotate" e2 "" (cdr (assoc 10 l1)) (- (cvunit (cdr (assoc 50 l1)) "radians" "degrees")))
101.                     (vl-cmdf "_.explode" e2 "")
102.                     (entdel e2)
103.                     (setq e3ss (ssget "_P"))
104.                     (entdel e2)
105.                     (vl-cmdf "_.-block" (cdr (assoc 02 l1)) "_Y" (cdr (assoc 10 l1)) e3ss "")
106.                     (vl-cmdf "_.UCS" "p")
107.                     (vl-cmdf "_.-insert" (cdr (assoc 02 l1)) "_R" "0.0" "_non" '(0.0 0.0 0.0) "1.0" "")
108.                     (entmod (subst (assoc 8 l1) (assoc 8 (entget (entlast))) (entget (entlast))))
109.                     (if (assoc 62 l1) (entmod (append (list (assoc 62 l1)) (entget (entlast)))))
110.                     (entupd (entlast))
111.                 )
112.             )
113.         )
114.         (alert "\nPick block - picked object wasn't block entity")
115.     )
116.     (vl-cmdf "_.UCS" "p")
117.     (vl-cmdf "_.UCS" "p")
118.     (princ)
119. )
120.  

M.R.