(SDSCALE)对象距离缩放(只改变对象距离位置，不改变对象大小)
本帖最后由 fangmin723 于 2021-6-24 11:21 编辑;;说明:对象距离缩放(只改变对象距离位置，不改变对象大小) by 忘霄 2021.5.12
(defun C:SDSCALE(/ *error* bf-mat-translation ent iscpy mat n nmidpt obj omidpt p0 pc0 pc1 pc2 sca scae scas ss)
(vl-load-com)
(defun *error*(msg)
(if (= iscpy T) (command-S "_.ERASE" ss ""))
(prin1)
)
;;;name:BF-Mat-Translation
;;;desc:根据矢量计算平移矩阵
;;;arg:v:平移矢量
;;;return:4X4的平移矩阵
;;;example:(BF-Mat-Translation '(1 0 0))
(defun BF-Mat-Translation (v)
(list
(list 1. 0. 0. (float (car v)))
(list 0. 1. 0. (float (cadr v)))
(list 0. 0. 1. (float (caddr v)))
(list 0. 0. 0. 1.)
)
)
(if (and (setq ss (ssget)) (setq p0 (getpoint "\n指定距离缩放中心点：")))
(progn
(setq iscpy nil n -1)
(initget "C c R r")
(setq sca (getdist p0 "\n指定缩放比例或 [复制(C)/参照(R)] <1.00>："))
(if (or (= p0 "") (= p0 nil)) (setq sca 1.0))
(while (= (type sca) 'STR)
(setq sca (strcase sca))
(cond
((and (not iscpy) (equal sca "C"))
(command "_.COPY" ss "" "non" '(0 0 0) "non" '(0 0 0))
(setq iscpy T)
(initget "R r")
(setq sca (getdist p0 "指定缩放比例或 [参照(R)] <1.00>："))
(if (or (= p0 "") (= p0 nil)) (setq sca 1.0))
)
((equal sca "R")
(setq pc0 (getpoint "\n指定参照长度 <1.00>："))
(if (or (= pc0 "") (= pc0 nil))
(progn
(setq pc0 p0 scas 1.0 pc2 (getpoint pc0 "\n指定新长度<1.00>："))
(if (or (= pc2 "") (= pc2 nil))
(setq scae 1.0)
(setq scae (distance pc0 pc2))
)
)
(progn
(setq pc1 (getpoint pc0 "指定第二点："))
(if (or (= pc1 "") (= pc1 nil))
(setq scas 1.0)
(progn
(setq scas (distance pc0 pc1) pc2 (getpoint pc0 "\n指定新长度<1.00>："))
(if (or (= pc2 "") (= pc2 nil))
(setq scae 1.0)
(setq scae (distance pc0 pc2))
)
)
)
)
)
(setq sca (/ scae scas))
)
)
)
(while (setq ent (ssname ss (setq n (1+ n))))
(setq obj (vlax-ename->vla-object ent))
(vla-GetBoundingBox obj 'mn 'mx)
(setq omidpt (mapcar '* (mapcar '+ (vlax-safearray->list mn) (vlax-safearray->list mx)) (list 0.5 0.5 0.5)))
(setq nmidpt (polar p0 (angle p0 omidpt) (* sca (distance p0 omidpt))))
(setq mat (vlax-make-safearray vlax-vbDouble '(0 . 3) '(0 . 3)))
(vlax-safearray-fill mat (BF-Mat-Translation (mapcar '- nmidpt omidpt)))
(vla-TransformBy obj mat)
)
)
)
(prin1)
)
(princ "\n对象距离缩放：SDSCALE！")
(prin1)
非常好用，谢谢大神！ 顶起顶起，，谢谢楼主的无私奉献，一个好的想法和功能实现了 如果能支持三维对象的3坐标缩放，那就跟橱柜的爆炸功能一样强大了 本帖最后由 xyp1964 于 2024-1-13 10:20 编辑
(defun c:tt ()
"对象距离缩放(只改变对象距离位置，不改变对象大小)"
(defun Ureal (bit kwd msg def / inp)
(if def
(setq msg (strcat "\n" msg "<" (rtos def 2) ">: ")
bit (* 2 (fix (/ bit 2)))
)
(setq msg (strcat "\n" msg ": "))
)
(initget bit kwd)
(setq inp (getreal msg))
(if inp inp def)
)
(defun cen (s1 / x y a b)
(vla-GetBoundingBox (vlax-ename->vla-object s1) 'a 'b)
(mapcar '(lambda (x y) (* (+ x y) 0.5))(vlax-safearray->list a)(vlax-safearray->list b))
)
(defun ss2list (ss)
(vl-remove-if-not'(lambda (x) (equal (type x) 'ENAME))(mapcar 'cadr (ssnamex ss)))
)
;;
(or sc (setq sc 2.))
(setq sc (Ureal 7 "" "缩放比例" sc))
(if (and (setq ss (ssget))
(setq p0 (getpoint "\n缩放基点<退出>: "))
)
(setq lst (mapcar '(lambda (x)
(setq p1 (cen x)
dd (* (distance p0 p1) sc)
p2 (polar p0 (angle p0 p1) dd)
)
(command "move" x "" "non" p1 "non" p2)
)
(ss2list ss)
)
)
)
(princ)
)
本帖最后由 xyp1964 于 2024-1-13 10:51 编辑
(defun c:tt ()
"对象距离缩放(只改变对象距离位置，不改变对象大小)"
(xyp-Start)
(or sc (setq sc 2.))
(setq sc (Ureal 7 "" "缩放比例" sc))
(princ "\n选择实体<退出>: ")
(if (and (setq ss (ssget))(setq p0 (getpoint "\n缩放中心<退出>: ")))
(mapcar '(lambda (x)
(setq p1 (xyp-9pt x 5) dd (* (distance p0 p1) sc)p2 (polar p0 (angle p0 p1) dd))
(xyp-move x p1 p2)
)
(xyp-ss2list ss)
)
)
(xyp-End)
)
潇湘飞雨 发表于 2024-1-12 11:44
如果能支持三维对象的3坐标缩放，那就跟橱柜的爆炸功能一样强大了
感谢院长指导~我去测试下 xyp1964 发表于 2024-1-13 10:16
院长，已测试
十分感谢，代码已实现对三维对象的支持，
目前缩放的对象都在同一平面上
实现Z轴的缩放是否可行？
可否赐教
本帖最后由 xyp1964 于 2024-1-13 16:47 编辑
(defun c:tt ()
"对象距离缩放(只改变对象距离位置，不改变对象大小)"
(xyp-Start)
(or sc (setq sc 2.))
(setq sc (Ureal 7 "" "缩放比例" sc))
(princ "\n选择实体<退出>: ")
(if (and (setq ss (ssget))
(setq p0 (getpoint "\n缩放中心<退出>: "))
)
(mapcar '(lambda (x)
(setq p1 (xyp-9pt x 5)
dd (* (distance p0 p1) sc)
p2 (xyp-PtAlong2PtByDist p0 p1 dd)
)
(xyp-movex p1 p2)
)
(xyp-ss2list ss)
)
)
(xyp-End)
)
xyp1964 发表于 2024-1-13 16:41
帅炸了~ 已测试 非常完美！
页:
[1]