[LISP程序]：按照比例copy

tomtom

给大架提供一个copy程序
要求1。图纸必须按照比例绘制
      2。只限平面正交
      3。可进行多次不等间距

2. 
   
3. [FONT=courier new]
   
4. (defun c:copy1()
   
5. (if (= bl  nil)(setq bl (getreal "\ninput bl---:")))(setvar "userr1" bl)
   
6. (setq s (ssget))
   
7. (setq p1 (getpoint "\ninpurt base point:"))
   
8. (setq p2 (getpoint "\ninpurt direction:"))
   
9. (setq x1 (car p1) y1 (cadr p1) x2 (car p2) y2 (cadr p2))
   
10. (setq  xx (- x2 x1) yy (- y2 y1))
    
11. (setq xa (abs xx) ya (abs yy) xxx (- ya xa))
    
12. (setq dis1 (getreal "\ninput distance:"))(setq last1 dis1)
    
13. (setq dis3 dis1)(setq ddd 1)
    
14. (while (/= ddd nil)
    
15.    (if (< xxx 0)(progn
    
16.        (if (> x2 x1)(progn
    
17.            (setq base p1)
    
18.            (setq dis2 (/ dis1 bl))
    
19.            (setq p3 (polar p1 0 dis2))
    
20.            (command "copy" s "" base p3)
    
21.            (setq base p3)
    
22.            (setq dis1 (getreal "\ninput distance<exit><0-last>:"))
    
23.            (if (/= dis1 nil)(progn
    
24.              (if (= dis1 0) (setq dis1 last1))
    
25.              (setq dis1 (+ dis1 0.001))
    
26.              (setq last1 dis1)
    
27.              (setq dis3 (+ dis3 dis1)) (setq dis1 dis3)
    
28.              ))
    
29.            (if (= dis1 nil)(setq ddd nil))
    
30.            ))
    
31.        (if (< x2 x1)(progn
    
32.            (setq base p1)
    
33.            (setq dis2 (/ dis1 bl) dis2 (- 0 dis2))
    
34.            (setq p3 (polar p1 0 dis2))
    
35.            (command "copy" s "" base p3)
    
36.            (setq base p3)
    
37.            (setq dis1 (getreal "\ninput distance<exit><0-last>:"))
    
38.            (if (/= dis1 nil)(progn
    
39.              (if (= dis1 0) (setq dis1 last1))
    
40.              (setq dis1 (+ dis1 0.001))
    
41.              (setq last1 dis1)
    
42.              (setq dis3 (+ dis3 dis1)) (setq dis1 dis3)
    
43.              ))
    
44.            (if (= dis1 nil)(setq ddd nil))
    
45.            ))
    
46.         ))
    
47.    (if (> xxx 0)(progn
    
48.        (if (> y2 y1)(progn
    
49.            (setq base p1)
    
50.            (setq dis2 (/ dis1 bl))
    
51.            (setq p3 (polar p1 (/ pi 2) dis2))
    
52.            (command "copy" s "" base p3)
    
53.            (setq base p3)
    
54.            (setq dis1 (getreal "\ninput distance<exit><0-last>:"))
    
55.            (if (/= dis1 nil)(progn
    
56.              (if (= dis1 0) (setq dis1 last1))
    
57.              (setq dis1 (+ dis1 0.001))
    
58.              (setq last1 dis1)
    
59.              (setq dis3 (+ dis3 dis1)) (setq dis1 dis3)
    
60.              ))
    
61.            (if (= dis1 nil)(setq ddd nil))
    
62.            ))
    
63.        (if (< y2 y1)(progn
    
64.            (setq base p1)
    
65.            (setq dis2 (/ dis1 bl) dis2 (- 0 dis2))
    
66.            (setq p3 (polar p1 (/ pi 2) dis2))
    
67.            (command "copy" s "" base p3)
    
68.            (setq base p3)
    
69.            (setq dis1 (getreal "\ninput distance<exit><0-last>:"))
    
70.            (if (/= dis1 nil)(progn
    
71.              (if (= dis1 0) (setq dis1 last1))
    
72.              (setq dis1 (+ dis1 0.001))
    
73.              (setq last1 dis1)
    
74.              (setq dis3 (+ dis3 dis1)) (setq dis1 dis3)
    
75.              ))
    
76.            (if (= dis1 nil)(setq ddd nil))
    
77.            ))
    
78.         ))
    
79. )
    
80. )[/FONT]

<br /> [FONT=courier new]<br /> (defun c:copy1()<br /> (if (= bl  nil)(setq bl (getreal "\ninput bl---:")))(setvar "userr1" bl)<br /> (setq s (ssget))<br /> (setq p1 (getpoint "\ninpurt base point:"))<br /> (setq p2 (getpoint "\ninpurt direction:"))<br /> (setq x1 (car p1) y1 (cadr p1) x2 (car p2) y2 (cadr p2))<br /> (setq  xx (- x2 x1) yy (- y2 y1))<br /> (setq xa (abs xx) ya (abs yy) xxx (- ya xa))<br /> (setq dis1 (getreal "\ninput distance:"))(setq last1 dis1)<br /> (setq dis3 dis1)(setq ddd 1)<br /> (while (/= ddd nil)<br />    (if (< xxx 0)(progn<br />        (if (> x2 x1)(progn<br />            (setq base p1)<br />            (setq dis2 (/ dis1 bl))<br />            (setq p3 (polar p1 0 dis2))<br />            (command "copy" s "" base p3)<br />            (setq base p3)<br />            (setq dis1 (getreal "\ninput distance<exit><0-last>:"))<br />            (if (/= dis1 nil)(progn<br />              (if (= dis1 0) (setq dis1 last1))<br />              (setq dis1 (+ dis1 0.001))<br />              (setq last1 dis1)<br />              (setq dis3 (+ dis3 dis1)) (setq dis1 dis3)<br />              ))<br />            (if (= dis1 nil)(setq ddd nil))<br />            ))<br />        (if (< x2 x1)(progn<br />            (setq base p1)<br />            (setq dis2 (/ dis1 bl) dis2 (- 0 dis2))<br />            (setq p3 (polar p1 0 dis2))<br />            (command "copy" s "" base p3)<br />            (setq base p3)<br />            (setq dis1 (getreal "\ninput distance<exit><0-last>:"))<br />            (if (/= dis1 nil)(progn<br />              (if (= dis1 0) (setq dis1 last1))<br />              (setq dis1 (+ dis1 0.001))<br />              (setq last1 dis1)<br />              (setq dis3 (+ dis3 dis1)) (setq dis1 dis3)<br />              ))<br />            (if (= dis1 nil)(setq ddd nil))<br />            ))<br />         ))<br />    (if (> xxx 0)(progn<br />        (if (> y2 y1)(progn<br />            (setq base p1)<br />            (setq dis2 (/ dis1 bl))<br />            (setq p3 (polar p1 (/ pi 2) dis2))<br />            (command "copy" s "" base p3)<br />            (setq base p3)<br />            (setq dis1 (getreal "\ninput distance<exit><0-last>:"))<br />            (if (/= dis1 nil)(progn<br />              (if (= dis1 0) (setq dis1 last1))<br />              (setq dis1 (+ dis1 0.001))<br />              (setq last1 dis1)<br />              (setq dis3 (+ dis3 dis1)) (setq dis1 dis3)<br />              ))<br />            (if (= dis1 nil)(setq ddd nil))<br />            ))<br />        (if (< y2 y1)(progn<br />            (setq base p1)<br />            (setq dis2 (/ dis1 bl) dis2 (- 0 dis2))<br />            (setq p3 (polar p1 (/ pi 2) dis2))<br />            (command "copy" s "" base p3)<br />            (setq base p3)<br />            (setq dis1 (getreal "\ninput distance<exit><0-last>:"))<br />            (if (/= dis1 nil)(progn<br />              (if (= dis1 0) (setq dis1 last1))<br />              (setq dis1 (+ dis1 0.001))<br />              (setq last1 dis1)<br />              (setq dis3 (+ dis3 dis1)) (setq dis1 dis3)<br />              ))<br />            (if (= dis1 nil)(setq ddd nil))<br />            ))<br />         ))<br /> )<br /> )[/FONT]

梦断江南

不限制角度，可用鼠标拉出方向输入距离。当然也支持@100<25这样的表达。

2. [FONT=century gothic]
   
3. ;cc.lsp(cc)连续相对点拷贝 ------lxx-----2001.2
   
4. ;下一基点可输入与上一基点的相对值
   
5. ;请保留princ信息行。
   
6. ;_______________________________________
   
7. (defun c:cc ()
   
8. (princ "\n连续相对点拷贝")
   
9. (setq ss (ssget) pt1 (getpoint "\n基点:") tt "true")
   
10. (command "copy" ss "" pt1 pt1)
    
11. (while tt
    
12.   (princ "\n下一基点:")
    
13.   (command "move" ss "" pt1 pause)
    
14.   (setq pt2 (getvar "lastpoint"))
    
15.   (if (equal pt1 pt2)
    
16.    (progn(entdel ss)(setq tt nil))
    
17.    (progn(setq pt1 pt2)(command "copy" ss "" pt2 pt2))
    
18.   )
    
19. )(princ)
    
20. )
    
21. (princ "\ncc.lsp(c:cc)连续相对点拷贝 ------lxx-----2001.2")(princ)
    
22. [/FONT]

[FONT=century gothic]<br /> ;cc.lsp(cc)连续相对点拷贝 ------lxx-----2001.2<br /> ;下一基点可输入与上一基点的相对值<br /> ;请保留princ信息行。<br /> ;_______________________________________<br /> (defun c:cc ()<br /> (princ "\n连续相对点拷贝")<br /> (setq ss (ssget) pt1 (getpoint "\n基点:") tt "true")<br /> (command "copy" ss "" pt1 pt1) <br /> (while tt<br />   (princ "\n下一基点:")<br />   (command "move" ss "" pt1 pause)<br />   (setq pt2 (getvar "lastpoint"))<br />   (if (equal pt1 pt2)<br />    (progn(entdel ss)(setq tt nil))<br />    (progn(setq pt1 pt2)(command "copy" ss "" pt2 pt2))<br />   )<br /> )(princ)<br /> )<br /> (princ "\ncc.lsp(c:cc)连续相对点拷贝 ------lxx-----2001.2")(princ)<br /> [/FONT]