可否原位进行缩放

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

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

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

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

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

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

(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

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

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

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

你那个是块吗？

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

本帖最后由自贡黄明儒于 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

不是块。就是一般的图形

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

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

;;;复制属性块后放大或缩小: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

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

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

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

以为你那是属性块

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

谢谢各位，都可以用。

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

[已解答] 可否原位进行缩放

本帖子中包含更多资源

点评

评分