yaya-54 发表于 2013-12-10 09:35:27

可否原位进行缩放

如图上：第一排的图觉得小了，如何一次性在图原有位置进行放大缩小。图不限形状，可以圆，或方形或其它。谢谢！

yoyoho 发表于 2013-12-10 11:28:07

感谢 自贡黄明儒 G版 1993063 分享程序,学习了!

Gu_xl 发表于 2013-12-10 10:56:28

本帖最后由 Gu_xl 于 2013-12-10 11:02 编辑

实体原位缩放 By Gu_xl
(defun c:tt(/ 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)
)

依然小小鸟 发表于 2018-8-12 21:10:26

Gu_xl 发表于 2013-12-10 10:56
实体原位缩放 By Gu_xl

可以实现 X Y不同比例 原位缩放吗

菜卷鱼 发表于 2013-12-10 09:40:16

你那个是块吗？

自贡黄明儒 发表于 2013-12-10 10:12:02

本帖最后由 自贡黄明儒 于 2013-12-10 10:53 编辑

那就以圆心为基点缩放，矩形就先找到中点
;;原位缩放
(defun C:w1 (/ EN N NUM SS X Y)
(defun cen (en / MAXP MINP X Y)
    (vla-GetBoundingBox (vlax-ename->vla-object en) 'MinP 'MaxP)
    (setq MinP (vlax-safearray->list MinP))
    (setq MaxP (vlax-safearray->list MaxP))
    (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) MinP MaxP)
)
(setq ss (ssget))
(setq num (getreal "\n 放大比例 "))
(if (and num ss)
    (repeat (setq n (sslength ss))
      (setq en (ssname ss (setq n (1- n))))
      (vl-cmdf "_.scale" en "" (cen en) num)
    )
)
(princ)
)

yaya-54 发表于 2013-12-10 10:41:48

不是块。就是一般的图形

1993063 发表于 2013-12-10 11:11:58

本帖最后由 1993063 于 2013-12-9 17:17 编辑

;;;复制属性块后放大或缩小:2013.12.10 1993063
(Defun C:scsc (/ i pt s1 ss ss-end sc)
(setq i-1
      ss (ssget)
      sc (getreal "\n缩放比例:")
)
(setq pt1 (getpoint "\n指定第一点")
      pt2 (getpoint pt1 "\n指定第二点")
)
(setq ss-end (entlast))
(command "copy" ss "" pt1 pt2)
(setq ss-end (last_ent ss-end))
(progn
    (while (setq s1 (ssname ss-end (setq i (1+ i))))
      (setq pt (ENTMID s1))
      (Command "scale" s1 "" pt sc)
    )
)
)
(defun last_ent (en / ss)
(if en
    (progn
      (setq ss (ssadd))
      (while (setq en (entnext en))
      (if (not (member (cdr (assoc 0 (entget en)))
                         '("ATTRIB" "VERTEX" "SEQEND")
               )
            )
          (ssadd en ss)
      )                               ;if
      )                                 ;while
      (if (zerop (sslength ss))
      (setq ss nil)
      )
      ss
    )                                 ;progn
    (ssget "_x")
)                                     ;if
)
(Defun entmid ( ent /maxp maxp )
(setq ent (vlax-ename->vla-object ent))(vla-getboundingbox ent 'minp 'maxp)
(setq maxp (vlax-safearray->list maxp) minp (vlax-safearray->list minp))
(Mapcar '(Lambda (x) (* x 0.5)) (Mapcar '+ minp maxp))
)

1993063 发表于 2013-12-10 11:15:56

Gu_xl 发表于 2013-12-9 16:56 static/image/common/back.gif
实体原位缩放 By Gu_xl

超版这么快,才写(拼)出来

1993063 发表于 2013-12-10 11:17:11

以为你那是属性块

yaya-54 发表于 2013-12-10 13:00:33

谢谢各位，都可以用。
页: [1] 2 3 4
查看完整版本: 可否原位进行缩放