(SDSCALE)对象距离缩放(只改变对象距离位置，不改变对象大小)

fangmin723 · 发表于 2021-6-24 09:10:11

本帖最后由 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)

Cad船长 · 发表于 2021-6-24 11:12:52

非常好用，谢谢大神！

999999 · 发表于 2021-6-25 20:33:36

顶起顶起，，谢谢楼主的无私奉献，一个好的想法和功能实现了

潇湘飞雨 · 发表于 2024-1-12 11:44:34

如果能支持三维对象的3坐标缩放，那就跟橱柜的爆炸功能一样强大了

xyp1964 · 发表于 2024-1-13 10:16:04

本帖最后由 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)
)

(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:18:43

本帖最后由 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-13 15:40:18

潇湘飞雨发表于 2024-1-12 11:44
如果能支持三维对象的3坐标缩放，那就跟橱柜的爆炸功能一样强大了

感谢院长指导~ 我去测试下

潇湘飞雨 · 发表于 2024-1-13 16:03:14

xyp1964 发表于 2024-1-13 10:16

院长，已测试

十分感谢，代码已实现对三维对象的支持，
目前缩放的对象都在同一平面上
实现Z轴的缩放是否可行？
可否赐教

xyp1964 · 发表于 2024-1-13 16:41:20

本帖最后由 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-move x p1 p2)
)
(xyp-ss2list ss)
)
)
(xyp-End)
)

潇湘飞雨 · 发表于 2024-1-15 08:58:24

xyp1964 发表于 2024-1-13 16:41

帅炸了~ 已测试非常完美！

账号		自动登录	找回密码
密码			注册

[源码] (SDSCALE)对象距离缩放(只改变对象距离位置，不改变对象大小)

本帖子中包含更多资源

点评

本帖子中包含更多资源

本帖子中包含更多资源