求一个不等比缩放的lISP程序，不用输入比例因子，直接输入X. Y缩放的尺寸就好
;x,y方向不同比例缩放; ***XSCALE 6/22/2005***
;
;Copyleft Gu Wenwei
;
; ***************************************
; ****Author:Apooollo ****
; **** ****
; ****Wuxi Jiangsu China ****
; ***************************************
;
;
; This program takes selected objects, defines an anonymous block,
; then inserts the block at the original location, Scale by X,Y
(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)) ;;; 选择缩放实体
(if ss
(progn
(setvar "cmdecho" 0)
(setq bp (getpoint "缩放基准点 (<0,0,0>): "))
(if (not bp) (setq bp (list 0 0 0)))
(setq xscal (getreal "X向比例因子 <1>: "))
(if (not xscal) (setq xscal 1))
(setq yscal (getreal "Y向比例因子 <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 "X,Y不同比例缩放, 命令:XSCALE")
) 本帖最后由 龙吟小调 于 2015-10-22 21:33 编辑
zjy2999 发表于 2015-10-22 13:21 static/image/common/back.gif
;x,y方向不同比例缩放
; ***XSCALE 6/22/2005***
;
这程序试用了下，还是要输入X,Y比例因子才行。我想找的是输入命令，指定基点，再输入X，Y的尺寸就可以的程序。记得原来论坛好像有的，当时也下过就是丢失了找不到了。 看看是不是这样的
本帖最后由 龙吟小调 于 2016-3-21 21:19 编辑
laorenhao999 发表于 2016-3-12 02:37 http://bbs.mjtd.com/static/image/common/back.gif
看看是不是这样的
就是这个终于找到了，以前有过的丢了，很久没来了竟然一来就有收获 是很强大，但感觉不如动态块好用吧。可能用到的范围不一样！ 回帖是一种美德！感谢楼主的无私分享 谢谢 感谢楼主的无私分享 正需要 谢谢！ (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)
) htlaser 发表于 2017-12-13 18:15
感谢楼主的无私分享 正需要 谢谢！
不知道发的对不对，自己复制保存下