实体中心缩放
前几天收到明经通道一个朋友发了短消息，求助原位缩放，不知道原位缩放是否指视图中心缩放？暂且发一个视图中心缩放的源码和大家讨论:
(defun c:mysc (/ sc ss i en ent pts pt s1)
;;出错处理函数
(defun ss-errexit (msg)
(command)
(command)
(if (or (= msg "Function cancelled")
(= msg "quit / exit abort")
)
(princ msg)
(princ (strcat "\n错误: " msg))
)
(clos)
)
(svos)
(setq sc (getreal "\n请输入缩放比例<1.0>:"))
(if (null sc)
(setq sc 1.0)
)
(setq ss (ssget))
(setq i -1)
(setvar "OSMODE" 0)
(while (setq en (ssname ss (setq i (1+ i))))
(setq pt (ss-getencen en NIL))
(ss-en-scale en pt sc)
)
(clos)
)
(princ "\n高山流水图元中心缩放程序，命令mysc")
(princ)
;;;获取图元的视图中心
(defun ss-getencen (en onseg / Wmat Umat obj minPt maxPt)
(if (and onseg (= (getvar "WORLDUCS") 0))
(setq Wmat (gc:TMatrixFromTo 1 0)
Umat (gc:TMatrixFromTo 0 1)
)
)
(if en
(progn
(setq obj (vlax-ename->vla-object en))
(if Wmat
(vla-TransformBy obj (vlax-tmatrix Wmat))
)
(vla-GetBoundingBox obj 'minpt 'maxpt)
(setq minPt (vlax-safearray->list minPt))
(setq maxPt (vlax-safearray->list maxPt))
(if Umat
(vla-TransformBy obj (vlax-tmatrix Umat))
)
(midpt minpt maxpt)
)
)
)
;;;gile
(defun gc:TMatrixFromTo (from to)
(append
(mapcar
(function
(lambda (v o)
(append (trans v from to T) (list o))
)
)
(list '(1. 0. 0.) '(0. 1. 0.) '(0. 0. 1.))
(trans '(0. 0. 0.) to from)
)
(list '(0. 0. 0. 1.))
)
)
;;;图元基点缩放
(defun ss-en-scale (en pt sc / s1)
(setq s1 (ssadd)
s1 (ssadd en s1)
)
(vl-cmdf "_.SCALE" s1 "" pt sc)
)
;;;保存原来的设定
(defun svos ()
;;;记录初始变量
(setq gsls_oldosm (getvar "OSMODE") ;捕捉设定
gsls_oldoth (getvar "ORTHOMODE") ;正交设定
gsls_oldlye (getvar "CLAYER") ;当前层
gsls_oldclr (getvar "CECOLOR") ;当前颜色
gsls_plnwid (getvar "PLINEWID") ;线宽设定
gsls_oldltp (getvar "CELTYPE") ;保存当前线形
gsls_cmdecho (getvar "CMDECHO") ;命令形式
gsls_elev (getvar "ELEVATION")
gsls_pickstyle (getvar "PICKSTYLE")
gsls_olderr *error*
*error* ss-errexit
)
(vla-startundomark
(vla-get-activedocument (vlax-get-acad-object))
)
)
;;;恢复原来的设定
(defun clos ()
(vla-EndUndoMark
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(setvar "OSMODE" gsls_oldosm)
(setvar "ORTHOMODE" gsls_oldoth)
(setvar "CLAYER" gsls_oldlye)
(setvar "CECOLOR" gsls_oldclr)
(setvar "CELTYPE" gsls_oldltp)
(setvar "ELEVATION" gsls_elev)
(setvar "CMDECHO" gsls_cmdecho)
(setvar "PLINEWID" gsls_plnwid)
(setvar "PICKSTYLE" gsls_pickstyle)
(setq *error* gsls_olderr)
(prin1)
)
;;;求两点中点
(defun midpt (pta ptb)
(mapcar (function (lambda (x y)
(/ (+ x y) 2.0)
)
)
pta
ptb
)
)
能不能以图形的形心，原位置放大缩小 ;; 保存原来的设定
(defun svos ()
(setq #system# '("OSMODE" "ORTHOMODE" "CLAYER" "CECOLOR" "PLINEWID" "CELTYPE" "CMDECHO" "ELEVATION" "PICKSTYLE")
#vlale# (mapcar 'getvar #system#)
gsls_olderr *error*
*error* ss-errexit
)
(vla-startundomark
(vla-get-activedocument (vlax-get-acad-object))
)
)
;; 恢复原来的设定
(defun clos ()
(vla-EndUndoMark
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(MapCar 'setvar #system# #vlale#)
(setq *error* gsls_olderr)
)
;; 求两点中点
(defun midpt (pta ptb)
(mapcar '(lambda (x y) (/ (+ x y) 2.0)) pta ptb)
) 谢谢院长指导！系统变量保存原本想采用AC_BONUS的表形式，但是由于使用不多，为了方便，就没有再修改了。
2楼朋友，如果要使用形心放大，那就必须是存在形心的实体 请问一下，我用的cad2010,楼主的程序放到vlisp里面出错
_$
; 错误: 参数类型错误: FILE nil
_$ 如果是参照基点缩放就好哈~ 这个很好用！谢谢！
页:
[1]