原地缩放

/db_自贡黄明儒_ · 发表于 2019-6-14 10:35:30

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;原地缩放 2014.2.8
(defun c:YDSF (/ A B CENP CMD1 OLDSCALE SC)
(vl-load-com)
(or *DOC*
(setq *DOC* (vla-get-ActiveDocument (vlax-get-acad-object)))
)
;(_StartUndo *DOC*)
;(HH:ayOSMode nil)
(setq cmd1 (getvar "cmdecho"))
(if (null oldscale)
(setq oldscale 2.0)
)
(initget 6)
(setq sc (getreal (strcat "\n 缩放倍数<" (rtos oldscale 2 2) ">:")))
(if (null sc)
(setq sc oldscale)
(setq oldscale sc)
)
(while (ssget ":S")
(vlax-for obj (vla-get-ActiveSelectionSet *DOC*)
(if (not (VL-CATCH-ALL-ERROR-P
(VL-CATCH-ALL-APPLY 'vla-GetBoundingBox (list obj 'a 'b))
)
)
(progn
(setq CenP (cons '+
(mapcar 'vlax-safearray->list
(list a b)
)
)
)
(setq CenP (apply 'mapcar CenP))
(setq CenP (mapcar '* '(0.5 0.5 0.5) CenP))
(vla-ScaleEntity obj (vlax-3d-point CenP) sc)
)
)
)
)
(setvar "cmdecho" cmd1)
;(HH:ayOSMode T)
;(_EndUndo *DOC*)
(gc)
(princ "\n 自贡运机集团黄明儒温馨提示,原地缩放命令:YDSF")
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;原地缩放 2014.2.8

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;原地缩放 2014.2.8 
(defun c:YDSF (/ A B CENP CMD1 OLDSCALE SC) 
  (vl-load-com) 
  (or *DOC* 
      (setq *DOC* (vla-get-ActiveDocument (vlax-get-acad-object))) 
  ) 
  ;(_StartUndo *DOC*) 
  ;(HH:ayOSMode nil) 
  (setq cmd1 (getvar "cmdecho")) 
  (if (null oldscale) 
    (setq oldscale 2.0) 
  ) 
  (initget 6) 
  (setq sc (getreal (strcat "\n 缩放倍数<" (rtos oldscale 2 2) ">:"))) 
  (if (null sc) 
    (setq sc oldscale) 
    (setq oldscale sc) 
  ) 
  (while (ssget ":S") 
    (vlax-for obj (vla-get-ActiveSelectionSet *DOC*) 
      (if (not (VL-CATCH-ALL-ERROR-P 
                 (VL-CATCH-ALL-APPLY 'vla-GetBoundingBox (list obj 'a 'b)) 
               ) 
          ) 
        (progn 
          (setq        CenP (cons '+ 
                           (mapcar 'vlax-safearray->list 
                                   (list a b) 
                           ) 
                     ) 
          ) 
          (setq CenP (apply 'mapcar CenP)) 
          (setq CenP (mapcar '* '(0.5 0.5 0.5) CenP)) 
          (vla-ScaleEntity obj (vlax-3d-point CenP) sc) 
        ) 
      ) 
    ) 
  ) 
  (setvar "cmdecho" cmd1) 
  ;(HH:ayOSMode T) 
  ;(_EndUndo *DOC*) 
  (gc) 
  (princ "\n 自贡运机集团黄明儒温馨提示,原地缩放命令:YDSF") 
  (princ) 
) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;原地缩放 2014.2.8

依然小小鸟 · 发表于 2019-6-14 12:04:32

http://bbs.mjtd.com/thread-178132-1-1.html 大神能看下这个怎么解决吗

HLCAD · 发表于 2019-6-14 15:11:23

感谢大师的源码！！！
晓东已经很难见到好贴了！

renyonghua2014 · 发表于 2019-6-14 15:27:43

黄大侠出现了，好啊好啊

137407536 · 发表于 2019-6-19 10:31:30

可以控制缩放基点就好了包围盒上下左右中

/db_自贡黄明儒_ · 发表于 2019-6-19 11:52:45

137407536 发表于 2019-6-19 10:31
可以控制缩放基点就好了包围盒上下左右中

每次选择，以共同的中心缩放的。

nik2221 · 发表于 2019-6-19 13:09:21

感谢大师的源码

木易成舟好 · 发表于 2019-10-4 16:49:59

(defun c:sf (/ sc a b)
 (if (null oldscale) (setq oldscale 2.0))
 (initget 6)
 (setq sc (getreal (strcat "\n缩放倍数<" (rtos oldscale 2 2)">:")))
 (if (null sc) (setq sc oldscale) (setq oldscale sc))
 (while (ssget)
(vlax-for obj
 (vla-get-ActiveSelectionSet
 (vla-get-ActiveDocument (vlax-get-acad-object)))
 (if (not (VL-CATCH-ALL-ERROR-P
 (VL-CATCH-ALL-APPLY
 'vla-GetBoundingBox
 (list obj 'a 'b))))
 (progn
 (vla-ScaleEntity
 obj
 (vlax-3d-point
 (mapcar
 '*
 '(0.5 0.5 0.5)
 (apply 'mapcar
 (cons '+
 (mapcar 'vlax-safearray->list
 (list a b))))))
 sc
 )
 )
 )
 )
)
 (princ)
 )
不知道是不是和这一个一样的

香远益清 · 发表于 2019-12-31 10:19:42

测试了，其实都不是原地缩放

相信自己666 · 发表于 2020-4-17 12:58:21

找的就是你，都是牛人

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

[每日一码] 原地缩放

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。