lisp xy轴不等比缩放_求一个不等比缩放的lISP程序，不用输入比例因子，直接输入X. Y缩放的尺寸就好...

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

(setvar "qaflags" 0)

(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 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 (cadr (ssgetfirst)))

(while (= ss nil)

(setq ss (ssget))                        ; 选择缩放实体

)

(setq        i 0

dwcorn nil

upcorn nil

)

(repeat (sslength ss)

(setq ent (ssname ss i))

(setq obj (vlax-ename->vla-object ent))

(vla-GetBoundingBox obj 'pta 'ptb)

(setq dwcorn (cons (vlax-safearray->list pta) dwcorn))

(setq upcorn (cons (vlax-safearray->list ptb) upcorn))

(setq i (1+ i))

)

(setq        ptlist (append

dwcorn

upcorn

)

)

(setq        x (mapcar

'car

ptlist

)

)

(setq        y (mapcar

'cadr

ptlist

)

)

(setq        x1 (apply

'min

x

)

)

(setq        y1 (apply

'min

y

)

)

(setq        x2 (apply

'max

x

)

)

(setq        y2 (apply

'max

y

)

)

(setq xx (- (car (list x2 y2)) (car (list x1 y1))))

(setq yy (- (cadr (list x2 y2)) (cadr (list x1 y1))))

(if ss

(progn

(setq bp (polar (list x1 y1)

(angle (list x1 y1) (list x2 y2))

(/ (distance (list x1 y1) (list x2 y2)) 2)

)

)

(setq xx1 (getdist "\n指定新的X方向尺寸:"))

(setq yy1 (getdist "\n指定新的Y方向尺寸:"))

(setq xscal (/ xx1 xx))

(setq yscal (/ yy1 yy))

(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)

)