;; 程序功能: 物体中心缩放,命令 scc,作者:qjchen
;; 注:此中心指的是物体的boundingbox(外包围圈矩形)的中心,非真正的形心
;; 仅对于圆形,方形等,此中心同形心
(vl-load-com)
(defun c:scc ()
(zxs)
(princ)
)
;;;subrountine to scale
(defun zxs (/ ssets scal len-ssets i entss objss res midpoint)
(prompt "\n请选择需要进行中心缩放的物体:")
(setq ssets (std-sslist (ssget)))
(setq scal (getreal "\n比例因子:"))
(foreach x ssets
(setq objss (vlax-ename->vla-object x))
(setq res (xyval1 objss))
(setq midpoint (midp (list (nth 0 res) (nth 1 res)) (list (nth 2 res) (nth 3 res))))
(vla-scaleentity objss (vlax-3D-point midpoint) scal) ;_ end of vla-scaleentity
)
)
;;; _ end of xyval
;;;;---The following codes are copy from Tony Hotchkiss at cadalyst
;;Get the boundingbox of one object
(defun xyval1 (obj / minpt maxpt pt1 pt2)
(vla-GetBoundingBox obj 'minpt 'maxpt)
(setq pt1 (vlax-safearray->list minpt)
pt2 (vlax-safearray->list maxpt)
) ; _ end of setq
(list (car pt1) (cadr pt1) (car pt2) (cadr pt2))
);;; =======================================================================;
;;; selection to list, by Reini Urban ;
;;; =======================================================================;
(defun std-sslist (ss / n lst)
(if (eq 'pickset (type ss))
(repeat (setq n (fix (sslength ss))) ; fixed
(setq lst (cons (ssname ss (setq n (1- n))) lst))))
)
;-------------------------------------------------------
(defun midp (p1 p2)
(mapcar '(lambda (x) (/ x 2.)) (mapcar '+ p1 p2))
)
(princ "\n By qjchen@gmail.com, 选择物体分别进行中心缩放, The command is scc")
(princ)