实体中心缩放

chlh_jd

前几天收到明经通道一个朋友发了短消息，求助原位缩放，不知道原位缩放是否指视图中心缩放？
暂且发一个视图中心缩放的源码和大家讨论:

2. 
   
3. (defun c:mysc (/ sc ss i en ent pts pt s1)
   
4.   ;;出错处理函数
   
5.   (defun ss-errexit (msg)
   
6.     (command)
   
7.     (command)
   
8.     (if (or (= msg "Function cancelled")
   
9.      (= msg "quit / exit abort")
   
10. )
    
11.       (princ msg)
    
12.       (princ (strcat "\n错误: " msg))
    
13.     )
    
14.     (clos)
    
15.   )
    
16.   (svos)
    
17.   (setq sc (getreal "\n请输入缩放比例<1.0>:"))
    
18.   (if (null sc)
    
19.     (setq sc 1.0)
    
20.   )
    
21.   (setq ss (ssget))
    
22.   (setq i -1)
    
23.   (setvar "OSMODE" 0)
    
24.   (while (setq en (ssname ss (setq i (1+ i))))
    
25.     (setq pt (ss-getencen en NIL))
    
26.     (ss-en-scale en pt sc)
    
27.   )
    
28.   (clos)
    
29. )
    
30. (princ "\n高山流水图元中心缩放程序，命令mysc")
    
31. (princ)
    
32. ;;;获取图元的视图中心
    
33. (defun ss-getencen (en onseg / Wmat Umat obj minPt maxPt)
    
34.   (if (and onseg (= (getvar "WORLDUCS") 0))
    
35.     (setq Wmat (gc:TMatrixFromTo 1 0)
    
36.    Umat (gc:TMatrixFromTo 0 1)
    
37.     )
    
38.   )
    
39.   (if en
    
40.     (progn
    
41.       (setq obj (vlax-ename->vla-object en))
    
42.       (if Wmat
    
43. (vla-TransformBy obj (vlax-tmatrix Wmat))
    
44.       )
    
45.       (vla-GetBoundingBox obj 'minpt 'maxpt)
    
46.       (setq minPt (vlax-safearray->list minPt))
    
47.       (setq maxPt (vlax-safearray->list maxPt))
    
48.       (if Umat
    
49. (vla-TransformBy obj (vlax-tmatrix Umat))
    
50.       )
    
51.       (midpt minpt maxpt)
    
52.     )
    
53.   )
    
54. )
    
55. ;;;gile
    
56. (defun gc:TMatrixFromTo (from to)
    
57.   (append
    
58.     (mapcar
    
59.       (function
    
60. (lambda (v o)
    
61.    (append (trans v from to T) (list o))
    
62. )
    
63.       )
    
64.       (list '(1. 0. 0.) '(0. 1. 0.) '(0. 0. 1.))
    
65.       (trans '(0. 0. 0.) to from)
    
66.     )
    
67.     (list '(0. 0. 0. 1.))
    
68.   )
    
69. )
    
70. ;;;图元基点缩放
    
71. (defun ss-en-scale (en pt sc / s1)
    
72.   (setq s1 (ssadd)
    
73. s1 (ssadd en s1)
    
74.   )
    
75.   (vl-cmdf "_.SCALE" s1 "" pt sc)
    
76. )
    
77. ;;;保存原来的设定
    
78. (defun svos ()
    
79. ;;;记录初始变量
    
80.   (setq gsls_oldosm    (getvar "OSMODE") ;捕捉设定
    
81. gsls_oldoth    (getvar "ORTHOMODE") ;正交设定
    
82. gsls_oldlye    (getvar "CLAYER") ;当前层
    
83. gsls_oldclr    (getvar "CECOLOR") ;当前颜色
    
84. gsls_plnwid    (getvar "PLINEWID") ;线宽设定
    
85. gsls_oldltp    (getvar "CELTYPE") ;保存当前线形
    
86. gsls_cmdecho   (getvar "CMDECHO") ;命令形式
    
87. gsls_elev      (getvar "ELEVATION")
    
88. gsls_pickstyle (getvar "PICKSTYLE")
    
89. gsls_olderr    *error*
    
90. *error*        ss-errexit
    
91.   )
    
92.   (vla-startundomark
    
93.     (vla-get-activedocument (vlax-get-acad-object))
    
94.   )
    
95. )
    
96. ;;;恢复原来的设定
    
97. (defun clos ()
    
98.   (vla-EndUndoMark
    
99.     (vla-get-ActiveDocument (vlax-get-acad-object))
    
100.   )
     
101.   (setvar "OSMODE" gsls_oldosm)
     
102.   (setvar "ORTHOMODE" gsls_oldoth)
     
103.   (setvar "CLAYER" gsls_oldlye)
     
104.   (setvar "CECOLOR" gsls_oldclr)
     
105.   (setvar "CELTYPE" gsls_oldltp)
     
106.   (setvar "ELEVATION" gsls_elev)
     
107.   (setvar "CMDECHO" gsls_cmdecho)
     
108.   (setvar "PLINEWID" gsls_plnwid)
     
109.   (setvar "PICKSTYLE" gsls_pickstyle)
     
110.   (setq *error* gsls_olderr)
     
111.   (prin1)
     
112. )
     
113. ;;;求两点中点
     
114. (defun midpt (pta ptb)
     
115.   (mapcar (function (lambda (x y)
     
116.         (/ (+ x y) 2.0)
     
117.       )
     
118.    )
     
119.    pta
     
120.    ptb
     
121.   )
     
122. )
     

<br /> (defun c:mysc (/ sc ss i en ent pts pt s1)<br />   ;;出错处理函数<br />   (defun ss-errexit (msg)<br />     (command)<br />     (command)<br />     (if (or (= msg "Function cancelled")<br />      (= msg "quit / exit abort")<br /> )<br />       (princ msg)<br />       (princ (strcat "\n错误: " msg))<br />     )<br />     (clos)<br />   )<br />   (svos)<br />   (setq sc (getreal "\n请输入缩放比例<1.0>:"))<br />   (if (null sc)<br />     (setq sc 1.0)<br />   )<br />   (setq ss (ssget))<br />   (setq i -1)<br />   (setvar "OSMODE" 0)<br />   (while (setq en (ssname ss (setq i (1+ i))))<br />     (setq pt (ss-getencen en NIL))<br />     (ss-en-scale en pt sc)<br />   )<br />   (clos)<br /> )<br /> (princ "\n高山流水图元中心缩放程序，命令mysc")<br /> (princ)<br /> ;;;获取图元的视图中心<br /> (defun ss-getencen (en onseg / Wmat Umat obj minPt maxPt)<br />   (if (and onseg (= (getvar "WORLDUCS") 0))<br />     (setq Wmat (gc:TMatrixFromTo 1 0)<br />    Umat (gc:TMatrixFromTo 0 1)<br />     )<br />   )<br />   (if en<br />     (progn<br />       (setq obj (vlax-ename->vla-object en))<br />       (if Wmat<br /> (vla-TransformBy obj (vlax-tmatrix Wmat))<br />       )<br />       (vla-GetBoundingBox obj 'minpt 'maxpt)<br />       (setq minPt (vlax-safearray->list minPt))<br />       (setq maxPt (vlax-safearray->list maxPt))<br />       (if Umat<br /> (vla-TransformBy obj (vlax-tmatrix Umat))<br />       )<br />       (midpt minpt maxpt)<br />     )<br />   )<br /> )<br /> ;;;gile <br /> (defun gc:TMatrixFromTo (from to)<br />   (append<br />     (mapcar<br />       (function<br /> (lambda (v o)<br />    (append (trans v from to T) (list o))<br /> )<br />       )<br />       (list '(1. 0. 0.) '(0. 1. 0.) '(0. 0. 1.))<br />       (trans '(0. 0. 0.) to from)<br />     )<br />     (list '(0. 0. 0. 1.))<br />   )<br /> )<br /> ;;;图元基点缩放<br /> (defun ss-en-scale (en pt sc / s1)<br />   (setq s1 (ssadd)<br /> s1 (ssadd en s1)<br />   )<br />   (vl-cmdf "_.SCALE" s1 "" pt sc)<br /> )<br /> ;;;保存原来的设定<br /> (defun svos ()<br /> ;;;记录初始变量<br />   (setq gsls_oldosm    (getvar "OSMODE") ;捕捉设定<br /> gsls_oldoth    (getvar "ORTHOMODE") ;正交设定<br /> gsls_oldlye    (getvar "CLAYER") ;当前层<br /> gsls_oldclr    (getvar "CECOLOR") ;当前颜色<br /> gsls_plnwid    (getvar "PLINEWID") ;线宽设定<br /> gsls_oldltp    (getvar "CELTYPE") ;保存当前线形<br /> gsls_cmdecho   (getvar "CMDECHO") ;命令形式<br /> gsls_elev      (getvar "ELEVATION")<br /> gsls_pickstyle (getvar "PICKSTYLE")<br /> gsls_olderr    *error*<br /> *error*        ss-errexit<br />   )<br />   (vla-startundomark<br />     (vla-get-activedocument (vlax-get-acad-object))<br />   )<br /> )<br /> ;;;恢复原来的设定<br /> (defun clos ()<br />   (vla-EndUndoMark<br />     (vla-get-ActiveDocument (vlax-get-acad-object))<br />   )<br />   (setvar "OSMODE" gsls_oldosm)<br />   (setvar "ORTHOMODE" gsls_oldoth)<br />   (setvar "CLAYER" gsls_oldlye)<br />   (setvar "CECOLOR" gsls_oldclr)<br />   (setvar "CELTYPE" gsls_oldltp)<br />   (setvar "ELEVATION" gsls_elev)<br />   (setvar "CMDECHO" gsls_cmdecho)<br />   (setvar "PLINEWID" gsls_plnwid)<br />   (setvar "PICKSTYLE" gsls_pickstyle)<br />   (setq *error* gsls_olderr)<br />   (prin1)<br /> )<br /> ;;;求两点中点<br /> (defun midpt (pta ptb)<br />   (mapcar (function (lambda (x y)<br />         (/ (+ x y) 2.0)<br />       )<br />    )<br />    pta<br />    ptb<br />   )<br /> )<br />

nameld001

能不能以图形的形心，原位置放大缩小

xyp1964

2. ;; 保存原来的设定
   
3. (defun svos ()
   
4.   (setq        #system#    '("OSMODE" "ORTHOMODE" "CLAYER" "CECOLOR" "PLINEWID" "CELTYPE" "CMDECHO" "ELEVATION" "PICKSTYLE")
   
5.         #vlale#            (mapcar 'getvar #system#)
   
6.         gsls_olderr *error*
   
7.         *error*            ss-errexit
   
8.   )
   
9.   (vla-startundomark
   
10.     (vla-get-activedocument (vlax-get-acad-object))
    
11.   )
    
12. )
    
13. ;; 恢复原来的设定
    
14. (defun clos ()
    
15.   (vla-EndUndoMark
    
16.     (vla-get-ActiveDocument (vlax-get-acad-object))
    
17.   )
    
18.   (MapCar 'setvar #system# #vlale#)
    
19.   (setq *error* gsls_olderr)
    
20. )
    
21. 
    
22. ;; 求两点中点
    
23. (defun midpt (pta ptb)
    
24.   (mapcar '(lambda (x y) (/ (+ x y) 2.0)) pta ptb)
    
25. )

;; 保存原来的设定<br /> (defun svos ()<br />   (setq        #system#    '("OSMODE" "ORTHOMODE" "CLAYER" "CECOLOR" "PLINEWID" "CELTYPE" "CMDECHO" "ELEVATION" "PICKSTYLE")<br />         #vlale#            (mapcar 'getvar #system#)<br />         gsls_olderr *error*<br />         *error*            ss-errexit<br />   )<br />   (vla-startundomark<br />     (vla-get-activedocument (vlax-get-acad-object))<br />   )<br /> )<br /> ;; 恢复原来的设定<br /> (defun clos ()<br />   (vla-EndUndoMark<br />     (vla-get-ActiveDocument (vlax-get-acad-object))<br />   )<br />   (MapCar 'setvar #system# #vlale#)<br />   (setq *error* gsls_olderr)<br /> )<br /> <br /> ;; 求两点中点<br /> (defun midpt (pta ptb)<br />   (mapcar '(lambda (x y) (/ (+ x y) 2.0)) pta ptb)<br /> )

chlh_jd

谢谢院长指导！系统变量保存原本想采用AC_BONUS的表形式，但是由于使用不多，为了方便，就没有再修改了。
2楼朋友，如果要使用形心放大，那就必须是存在形心的实体

dafeilang

请问一下，我用的cad2010,楼主的程序放到vlisp里面出错


_$
; 错误: 参数类型错误: FILE nil
_$

flytoday

如果是参照基点缩放就好哈~

434939575

这个很好用！谢谢！