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?
(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)
)
(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 )
(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)
(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)
)
for me it does not work
Get an error messageSee the link http://www.theswamp.org/index.php?topic=12813.0
Bekomme eine Fehlermeldung
Command: BLKDYNSCALE
Select a insert :*Cancel*
Command:
Command:
??: no function definition: OSMARK
Why not simply:Hi , Lee Mac .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)
)
Sorry, yes the block must be 1x1 or smaller in dimension :-(