悬赏缩放LISP源码

随梦而飞

悬赏缩放LISP源码
file:///D:/Program%20Files/QQ/Users/1980006156/Image/$$S%7D~1NH~C%25CYAIL%60@D(@TS.gif
1、我的邮箱  1980006156qq.com
2、由于本人刚学LISP,请高手注明每行LISP语言的简要的说明性文字，方便我认真学一下，如有这个的教学更佳。
3、请提供联系方式在我的邮箱，以便悬赏到位，千万别不好意思，否则我会不安的。

4、缩放后原大样图的标注同演示，但标注数字不变。

664571221

x_s_s_1 发表于 2012-8-3 18:41
严正声明！！子函数均来自明经，非本人原创，尺寸的比例由于不知道个人习惯没有处理

你好在吗能否 吧比例因子记住 ，输入一次就可以

疯球

多谢分享，体验一下

flytoday

建议到明经交易版块去…………………

x_s_s_1

严正声明！！子函数均来自明经，非本人原创，尺寸的比例由于不知道个人习惯没有处理

2. (vl-load-com)
   
3. ;;;lst_ssn函数(lst_ssn ss)
   
4. ;;;ss参数：选折集
   
5. ;;;返回图元名表
   
6. (defun lst_ssn (ss / n lst)
   
7.   (repeat (setq N (sslength ss))
   
8.     (setq LST (cons (ssname SS (setq N (1- N))) LST))
   
9.   ) ;_ 结束repeat
   
10. ) ;_ 结束defun
    
11. ;;;计算曲线交点
    
12. (defun Curveinters (en1 en2 / pl pts)
    
13.   (setq pl  (vlax-invoke (vlax-ename->vla-object en2) 'IntersectWith (vlax-ename->vla-object en1) acExtendNone))
    
14.   (while pl
    
15.     (setq pts (append pts (list (list (car pl) (cadr pl) (caddr pl))))
    
16.    pl (cdr (cdr (cdr pl)))
    
17.    )
    
18.     )
    
19. pts
    
20.   )
    
21. (defun zsf (/ ss_all ss_dot ss_sc ss_pts pt ssets scal x objss )
    
22.   (setvar "cmdecho" 0)
    
23.   (prompt "\n请选择需要进行缩放的物体:")   
    
24.   (setq ss_all (ssget));此处可根据个人习惯增加图层(ssget  '((8 . "colu,dim,sbar,dote,axis")))
    
25.   (setq ss_dot (ssget "p" '((0 . "*line") (8 . "dote,axis"))));此处图层根据个人习惯改
    
26.   (command "._Select" ss_all "remove" ss_dot "")
    
27.   (setq ss_sc (ssget "p"))
    
28.   (setq ss_pts (lst_ssn ss_dot))
    
29.   (setq pt (car(Curveinters (car ss_pts) (cadr ss_pts))))
    
30.   (setq ssets (lst_ssn ss_sc))
    
31.   (setq scal (getreal "\n比例因子:"))  
    
32.   (foreach x ssets  
    
33.     (setq objss (vlax-ename->vla-object x))  
    
34.     (vla-scaleentity objss (vlax-3D-point pt) scal)
    
35.   )  
    
36. )
    
37. (defun c:scc ()  
    
38.   (zsf)  
    
39.   (princ)  
    
40. )
    
41. 
    

(vl-load-com)<br /> ;;;lst_ssn函数(lst_ssn ss)<br /> ;;;ss参数：选折集<br /> ;;;返回图元名表<br /> (defun lst_ssn (ss / n lst)<br />   (repeat (setq N (sslength ss))<br />     (setq LST (cons (ssname SS (setq N (1- N))) LST))<br />   ) ;_ 结束repeat<br /> ) ;_ 结束defun<br /> ;;;计算曲线交点<br /> (defun Curveinters (en1 en2 / pl pts)<br />   (setq pl  (vlax-invoke (vlax-ename->vla-object en2) 'IntersectWith (vlax-ename->vla-object en1) acExtendNone))<br />   (while pl<br />     (setq pts (append pts (list (list (car pl) (cadr pl) (caddr pl))))<br />    pl (cdr (cdr (cdr pl)))<br />    )<br />     )<br /> pts<br />   )<br /> (defun zsf (/ ss_all ss_dot ss_sc ss_pts pt ssets scal x objss )<br />   (setvar "cmdecho" 0)<br />   (prompt "\n请选择需要进行缩放的物体:")    <br />   (setq ss_all (ssget));此处可根据个人习惯增加图层(ssget  '((8 . "colu,dim,sbar,dote,axis")))<br />   (setq ss_dot (ssget "p" '((0 . "*line") (8 . "dote,axis"))));此处图层根据个人习惯改<br />   (command "._Select" ss_all "remove" ss_dot "")<br />   (setq ss_sc (ssget "p"))<br />   (setq ss_pts (lst_ssn ss_dot))<br />   (setq pt (car(Curveinters (car ss_pts) (cadr ss_pts))))<br />   (setq ssets (lst_ssn ss_sc))<br />   (setq scal (getreal "\n比例因子:"))  <br />   (foreach x ssets  <br />     (setq objss (vlax-ename->vla-object x))  <br />     (vla-scaleentity objss (vlax-3D-point pt) scal) <br />   )  <br /> )<br /> (defun c:scc ()  <br />   (zsf)  <br />   (princ)  <br /> ) <br /> <br />

xiaodao520

建议楼主上测试图。赏在哪啊，楼主。还有点就是别人的代码，楼主千万别吹牛说是自己编的哦。我们都在看着。

flytoday

这个用不了。要让轴线不动。封闭多边形各边向轴线方向缩小

flytoday

1111111111111111111111111111111111111111111111111111111111111111

xyp1964

未考虑尺寸的缩小：

xiaodao520

xyp1964 发表于 2012-8-3 21:15
未考虑尺寸的缩小：

不是理想的效果，继续努力，校长

x_s_s_1

xiaodao520 发表于 2012-8-3 20:05
建议楼主上测试图。赏在哪啊，楼主。还有点就是别人的代码，楼主千万别吹牛说是自己编的哦。我们都在看着。

看来还要加一句啊，这个东西本来就是copy别人改的，本人从来不改别人函数名及变量名！！我也没说自己编的啊

xiaodao520

x_s_s_1 发表于 2012-8-3 21:30
看来还要加一句啊，这个东西本来就是copy别人改的，本人从来不改别人函数名及变量名！！我也没说自己编 ...

我不是说你，因为你不是楼主，我说的是随梦而飞