xy自由图框，测量、地质用得上

wzg356

2. ;;;
   
3. ;;;    命令：BGTK
   
4. ;;;
   
5. ;;;   在地形图上插入图框（包括坐标十字符号）
   
6. ;;;
   
7. ;;;    作者：凉开水   2005.09.25
   
8. ;;;WZG356 改于20140916,完善出错处理及十字丝判断退出
   
9. ;;;-----------------------------------------------------------------
   
10. ;;;
    
11. (defun c:BGTK ( / newerr *olderror* x p1 p2 p3 p4 nx ny px1 px2 py1 py2 pyx pxy)
    
12. 
    
13. ;自定义新的出错函数
    
14.     (defun newerr (msg)
    
15.       (mapcar 'eval sysvarlst);恢复变量设置
    
16.       (if *olderror* (setq *error* *olderror*  *olderror* nil)) ;_ 恢复*error*函数
    
17.       (if (not (member msg '(nil "函数被取消" ";错误:quit / exit abort")))
    
18.         (princ (strcat ";错误:" msg))
    
19.     )
    
20.   )
    
21.   ;;系统设置
    
22.   (command "undo" "be");;命令编组开始
    
23.   (setq sysvarlst(mapcar (function (lambda (n) (list 'setvar n (getvar n))))
    
24.       '( "osmode" "cmdecho" "OSNAPCOORD" "dimzin" "plinewid" ))
    
25.   );保存系统变量
    
26.   (setq *olderror* *error*);保存出错函数
    
27.   (setq  *error* newerr);设置自定义出错函数  
    
28.   
    
29.   (setvar "cmdecho" 0);;;关闭命令响应
    
30.   (setvar "OSNAPCOORD" 1);;;坐标数据优先级设为：键盘输入替代对象捕捉设置
    
31.   (setvar "OSMODE" 687);;;改变捕捉模式
    
32.   (setvar "dimzin" 0);;;不对主单位值作消零处理
    
33. 
    
34.   (if (= (Tblsearch "style" "MY_ST") nil)
    
35.     (command "-style" "MY_ST" "宋体" 0 0.8 0 "n" "n");;;文字样式
    
36.   )
    
37.   (command "textstyle" "MY_ST")
    
38. 
    
39. 
    
40.     (princ "\n假定CAD中绘制比例为1:1千")
    
41.   (if (not (setq x (getreal "\n输入出图比例,1代表1:1千,10代表1:1万，以此类推<1>: ")))(setq x 1.0))  
    
42.   
    
43.   ;;;四角坐标点
    
44.   (setq x (/ 1.0 x)
    
45.         pt1 (getpoint "\n指定第一角点: ")
    
46.         pt2 (getcorner pt1 "\n指定另一角点: ")
    
47.   )
    
48.   (if (> (car pt1) (car pt2))
    
49.     (if  (> (cadr pt1) (cadr pt2))
    
50.       (setq p1 pt2
    
51.       p2 (list (car pt1) (cadr pt2))
    
52.       p3 pt1
    
53.       p4 (list (car pt2) (cadr pt1))
    
54.       )
    
55.       (setq p1 (list (car pt2) (cadr pt1))
    
56.       p2 pt1
    
57.       p3 (list (car pt1) (cadr pt2))
    
58.       p4 pt2
    
59.       )
    
60.     )
    
61.     (if  (> (cadr pt1) (cadr pt2))
    
62.       (setq p1 (list (car pt1) (cadr pt2))
    
63.       p2 pt2
    
64.       p3 (list (car pt2) (cadr pt1))
    
65.       p4 pt1
    
66.       )
    
67.       (setq p1 pt1
    
68.       p2 (list (car pt2) (cadr pt1))
    
69.       p3 pt2
    
70.       p4 (list (car pt1) (cadr pt2))
    
71.       )
    
72.     )
    
73.   )
    
74. 
    
75.   (command "zoom" "w" (polar p1 (* pi 1.25) (* 2 (/ 20 x)))
    
76.           (polar p3 (* pi 0.25) (* 2 (/ 20 x)))
    
77.   )
    
78.   
    
79.   (command "rectang" p4 p2);;;画内框
    
80.   
    
81.   ;;;画外框
    
82.   (command "pline" (list 0 0 0) "w" (/ 0.4 x) (/ 0.4 x) "");;;定义线宽
    
83.   (command "pline" (list (-(car p1) (/ 10 x))(-(cadr p1) (/ 10 x)))
    
84.              (list (+(car p2) (/ 10 x))(-(cadr p2) (/ 10 x)))
    
85.                    (list (+(car p3) (/ 10 x))(+(cadr p3) (/ 10 x)))
    
86.                    (list (-(car p4) (/ 10 x))(+(cadr p4) (/ 10 x)))
    
87.      "c"
    
88.   )
    
89.   
    
90.   ;;;画四角短线
    
91.   (command "line" p1 (polar p1 (* pi 1) (/ 10 x)) "")
    
92.   (command "line" p1 (polar p1 (* pi 1.5) (/ 10 x)) "")
    
93.   (command "line" p2 (polar p2 (* pi 0) (/ 10 x)) "")
    
94.   (command "line" p2 (polar p2 (* pi 1.5) (/ 10 x)) "")
    
95.   (command "line" p3 (polar p3 (* pi 0) (/ 10 x)) "")
    
96.   (command "line" p3 (polar p3 (* pi 0.5) (/ 10 x)) "")
    
97.   (command "line" p4 (polar p4 (* pi 0.5) (/ 10 x)) "")
    
98.   (command "line" p4 (polar p4 (* pi 1) (/ 10 x)) "")
    
99.   
    
100.   ;;;写四角坐标值
     
101.   
     
102.   (command "text" "br" (polar p1 (* pi 1.687) (/ 5.78 x)) (/ 2.5 x) 0 (rtos (/ (car p1) 1000.0) 2 2))
     
103.   (command "text" "bc" (polar p1 (* pi 1) (/ 5 x)) (/ 2.5 x) 0 (rtos (/ (cadr p1) 1000.0) 2 2))
     
104.   (command "text" "br" (polar p2 (* pi 1.687) (/ 5.78 x)) (/ 2.5 x) 0 (rtos (/ (car p2) 1000.0) 2 2))
     
105.   (command "text" "bc" (polar p2 (* pi 0) (/ 5 x)) (/ 2.5 x) 0 (rtos (/ (cadr p2) 1000.0) 2 2))
     
106.   (command "text" "br" (polar p3 (* pi 0.2618) (/ 4.776 x)) (/ 2.5 x) 0 (rtos (/ (car p3) 1000.0) 2 2))
     
107.   (command "text" "bc" (polar p3 (* pi 0) (/ 5 x)) (/ 2.5 x) 0 (rtos (/ (cadr p3) 1000.0) 2 2))
     
108.   (command "text" "br" (polar p4 (* pi 0.2618) (/ 4.776 x)) (/ 2.5 x) 0 (rtos (/ (car p4) 1000.0) 2 2))
     
109.   (command "text" "bc" (polar p4 (* pi 1) (/ 5 x)) (/ 2.5 x) 0 (rtos (/ (cadr p4) 1000.0) 2 2))
     
110. 
     
111.   ;;;坐标十字的行列数     
     
112.   (setq nx (- (fix (/(car p2)(/ 100 x)))(fix (/( car p1)(/ 100 x))))
     
113.   ny (- (fix (/(cadr p4)(/ 100 x)))(fix (/( cadr p1)(/ 100 x))))
     
114.   )
     
115.   
     
116.    
     
117.    ;;;写内外框间坐标值
     
118.   (if (>=  nx 1)(progn
     
119.     (setq px1 (list (* (1+ (fix (/(car p1)(/ 100 x))))(/ 100 x))(cadr p1))
     
120.         px2 (list (* (1+ (fix (/(car p4)(/ 100 x))))(/ 100 x))(cadr p4)))
     
121.     (repeat nx
     
122.       (command "line" px1 (polar px1 (* pi 1.5) (/ 10 x)) "")
     
123.       (command "text" "br" (polar px1 (* pi 1.687) (/ 5.78 x)) (/ 2.5 x) 0 (rtos (/ (car px1) 1000.0) 2 2))
     
124.       (command "line" px2 (polar px2 (* pi 0.5) (/ 10 x)) "")
     
125.       (command "text" "br" (polar px2 (* pi 0.2618) (/ 4.776 x)) (/ 2.5 x) 0 (rtos (/ (car px2) 1000.0) 2 2))
     
126.       (setq px1 (list (+ (car px1)(/ 100 x))(cadr px1))
     
127.           px2 (list (+ (car px2)(/ 100 x))(cadr px2)))
     
128.   )
     
129.   ))
     
130.   (if (>=  ny 1)(progn
     
131.   (setq py1 (list (car p1)(* (1+ (fix (/(cadr p1)(/ 100 x))))(/ 100 x)))
     
132.       py2 (list (car p2)(* (1+ (fix (/(cadr p2)(/ 100 x))))(/ 100 x))))
     
133.   (repeat ny
     
134.     (command "line" py1 (polar py1 (* pi 1) (/ 10 x)) "")
     
135.     (command "text" "bc" (polar py1 (* pi 1) (/ 5 x)) (/ 2.5 x) 0 (rtos (/ (cadr py1) 1000.0) 2 2))
     
136.     (command "line" py2 (polar py2 (* pi 0) (/ 10 x)) "")
     
137.     (command "text" "bc" (polar py2 (* pi 0) (/ 5 x)) (/ 2.5 x) 0 (rtos (/ (cadr py2) 1000.0) 2 2))
     
138.     (setq py1 (polar py1 (* pi 0.5) (/ 100 x))
     
139.         py2 (polar py2 (* pi 0.5) (/ 100 x))
     
140.     )
     
141.   )
     
142.   ))
     
143. 
     
144.   ;;;画坐标十字  
     
145.   (if (or (>= nx 1) (>= ny 1))(progn
     
146.   (setq pyx (list (* (1+ (fix (/(car p1)(/ 100 x))))(/ 100 x))
     
147.       (* (1+ (fix (/(cadr p1)(/ 100 x))))(/ 100 x))));;;起始十字位置
     
148.     (repeat ny
     
149.       (setq pxy pyx)
     
150.        (repeat nx
     
151.         (command "line" (polar pxy (* pi 1) (/ 5 x)) (polar pxy (* pi 0) (/ 5 x))"")
     
152.         (command "line" (polar pxy (* pi 0.5) (/ 5 x)) (polar pxy (* pi 1.5) (/ 5 x))"")
     
153.         (setq pxy (list (+ (car pxy)(/ 100 x))(cadr pxy)))
     
154.     )
     
155.     (setq pyx (list (car pyx)(+ (cadr pyx)(/ 100 x))))
     
156.   )
     
157.   ))
     
158.   
     
159. ;;恢复设置
     
160.     (command "_undo" "_e");;活动编组结束
     
161.   (mapcar 'eval sysvarlst);恢复变量设置  
     
162.   (setq *error* *olderror*);;恢复出错函数
     
163.   (setq  *olderror* nil);;
     
164.   (princ)
     
165. )
     
166. ;;;
     
167. ;;;-----------------------------------------------------------------
     
168. ;;;
     

;;;<br /> ;;;    命令：BGTK<br /> ;;;<br /> ;;;   在地形图上插入图框（包括坐标十字符号）<br /> ;;;<br /> ;;;    作者：凉开水   2005.09.25<br /> ;;;WZG356 改于20140916,完善出错处理及十字丝判断退出<br /> ;;;-----------------------------------------------------------------<br /> ;;;<br /> (defun c:BGTK ( / newerr *olderror* x p1 p2 p3 p4 nx ny px1 px2 py1 py2 pyx pxy)<br /> <br /> ;自定义新的出错函数<br />     (defun newerr (msg)<br />       (mapcar 'eval sysvarlst);恢复变量设置<br />       (if *olderror* (setq *error* *olderror*  *olderror* nil)) ;_ 恢复*error*函数<br />       (if (not (member msg '(nil "函数被取消" ";错误:quit / exit abort")))<br />         (princ (strcat ";错误:" msg))<br />     )<br />   )<br />   ;;系统设置<br />   (command "undo" "be");;命令编组开始<br />   (setq sysvarlst(mapcar (function (lambda (n) (list 'setvar n (getvar n))))<br />       '( "osmode" "cmdecho" "OSNAPCOORD" "dimzin" "plinewid" ))<br />   );保存系统变量<br />   (setq *olderror* *error*);保存出错函数<br />   (setq  *error* newerr);设置自定义出错函数  <br />   <br />   (setvar "cmdecho" 0);;;关闭命令响应<br />   (setvar "OSNAPCOORD" 1);;;坐标数据优先级设为：键盘输入替代对象捕捉设置<br />   (setvar "OSMODE" 687);;;改变捕捉模式<br />   (setvar "dimzin" 0);;;不对主单位值作消零处理<br /> <br />   (if (= (Tblsearch "style" "MY_ST") nil)<br />     (command "-style" "MY_ST" "宋体" 0 0.8 0 "n" "n");;;文字样式<br />   )<br />   (command "textstyle" "MY_ST")<br /> <br /> <br />     (princ "\n假定CAD中绘制比例为1:1千")<br />   (if (not (setq x (getreal "\n输入出图比例,1代表1:1千,10代表1:1万，以此类推<1>: ")))(setq x 1.0))  <br />   <br />   ;;;四角坐标点<br />   (setq x (/ 1.0 x)<br />         pt1 (getpoint "\n指定第一角点: ")<br />         pt2 (getcorner pt1 "\n指定另一角点: ")<br />   )<br />   (if (> (car pt1) (car pt2))<br />     (if  (> (cadr pt1) (cadr pt2))<br />       (setq p1 pt2<br />       p2 (list (car pt1) (cadr pt2))<br />       p3 pt1<br />       p4 (list (car pt2) (cadr pt1))<br />       )<br />       (setq p1 (list (car pt2) (cadr pt1))<br />       p2 pt1<br />       p3 (list (car pt1) (cadr pt2))<br />       p4 pt2<br />       )<br />     )<br />     (if  (> (cadr pt1) (cadr pt2))<br />       (setq p1 (list (car pt1) (cadr pt2))<br />       p2 pt2<br />       p3 (list (car pt2) (cadr pt1))<br />       p4 pt1<br />       )<br />       (setq p1 pt1<br />       p2 (list (car pt2) (cadr pt1))<br />       p3 pt2<br />       p4 (list (car pt1) (cadr pt2))<br />       )<br />     )<br />   )<br /> <br />   (command "zoom" "w" (polar p1 (* pi 1.25) (* 2 (/ 20 x)))<br />           (polar p3 (* pi 0.25) (* 2 (/ 20 x)))<br />   )<br />   <br />   (command "rectang" p4 p2);;;画内框<br />   <br />   ;;;画外框<br />   (command "pline" (list 0 0 0) "w" (/ 0.4 x) (/ 0.4 x) "");;;定义线宽<br />   (command "pline" (list (-(car p1) (/ 10 x))(-(cadr p1) (/ 10 x)))<br />              (list (+(car p2) (/ 10 x))(-(cadr p2) (/ 10 x)))<br />                    (list (+(car p3) (/ 10 x))(+(cadr p3) (/ 10 x)))<br />                    (list (-(car p4) (/ 10 x))(+(cadr p4) (/ 10 x)))<br />      "c"<br />   )<br />   <br />   ;;;画四角短线<br />   (command "line" p1 (polar p1 (* pi 1) (/ 10 x)) "")<br />   (command "line" p1 (polar p1 (* pi 1.5) (/ 10 x)) "")<br />   (command "line" p2 (polar p2 (* pi 0) (/ 10 x)) "")<br />   (command "line" p2 (polar p2 (* pi 1.5) (/ 10 x)) "")<br />   (command "line" p3 (polar p3 (* pi 0) (/ 10 x)) "")<br />   (command "line" p3 (polar p3 (* pi 0.5) (/ 10 x)) "")<br />   (command "line" p4 (polar p4 (* pi 0.5) (/ 10 x)) "")<br />   (command "line" p4 (polar p4 (* pi 1) (/ 10 x)) "")<br />   <br />   ;;;写四角坐标值<br />   <br />   (command "text" "br" (polar p1 (* pi 1.687) (/ 5.78 x)) (/ 2.5 x) 0 (rtos (/ (car p1) 1000.0) 2 2))<br />   (command "text" "bc" (polar p1 (* pi 1) (/ 5 x)) (/ 2.5 x) 0 (rtos (/ (cadr p1) 1000.0) 2 2))<br />   (command "text" "br" (polar p2 (* pi 1.687) (/ 5.78 x)) (/ 2.5 x) 0 (rtos (/ (car p2) 1000.0) 2 2))<br />   (command "text" "bc" (polar p2 (* pi 0) (/ 5 x)) (/ 2.5 x) 0 (rtos (/ (cadr p2) 1000.0) 2 2))<br />   (command "text" "br" (polar p3 (* pi 0.2618) (/ 4.776 x)) (/ 2.5 x) 0 (rtos (/ (car p3) 1000.0) 2 2))<br />   (command "text" "bc" (polar p3 (* pi 0) (/ 5 x)) (/ 2.5 x) 0 (rtos (/ (cadr p3) 1000.0) 2 2))<br />   (command "text" "br" (polar p4 (* pi 0.2618) (/ 4.776 x)) (/ 2.5 x) 0 (rtos (/ (car p4) 1000.0) 2 2))<br />   (command "text" "bc" (polar p4 (* pi 1) (/ 5 x)) (/ 2.5 x) 0 (rtos (/ (cadr p4) 1000.0) 2 2))<br /> <br />   ;;;坐标十字的行列数     <br />   (setq nx (- (fix (/(car p2)(/ 100 x)))(fix (/( car p1)(/ 100 x))))<br />   ny (- (fix (/(cadr p4)(/ 100 x)))(fix (/( cadr p1)(/ 100 x))))<br />   )<br />   <br />    <br />    ;;;写内外框间坐标值<br />   (if (>=  nx 1)(progn<br />     (setq px1 (list (* (1+ (fix (/(car p1)(/ 100 x))))(/ 100 x))(cadr p1))<br />         px2 (list (* (1+ (fix (/(car p4)(/ 100 x))))(/ 100 x))(cadr p4)))<br />     (repeat nx<br />       (command "line" px1 (polar px1 (* pi 1.5) (/ 10 x)) "")<br />       (command "text" "br" (polar px1 (* pi 1.687) (/ 5.78 x)) (/ 2.5 x) 0 (rtos (/ (car px1) 1000.0) 2 2))<br />       (command "line" px2 (polar px2 (* pi 0.5) (/ 10 x)) "")<br />       (command "text" "br" (polar px2 (* pi 0.2618) (/ 4.776 x)) (/ 2.5 x) 0 (rtos (/ (car px2) 1000.0) 2 2))<br />       (setq px1 (list (+ (car px1)(/ 100 x))(cadr px1))<br />           px2 (list (+ (car px2)(/ 100 x))(cadr px2)))<br />   )<br />   ))<br />   (if (>=  ny 1)(progn<br />   (setq py1 (list (car p1)(* (1+ (fix (/(cadr p1)(/ 100 x))))(/ 100 x)))<br />       py2 (list (car p2)(* (1+ (fix (/(cadr p2)(/ 100 x))))(/ 100 x))))<br />   (repeat ny<br />     (command "line" py1 (polar py1 (* pi 1) (/ 10 x)) "")<br />     (command "text" "bc" (polar py1 (* pi 1) (/ 5 x)) (/ 2.5 x) 0 (rtos (/ (cadr py1) 1000.0) 2 2))<br />     (command "line" py2 (polar py2 (* pi 0) (/ 10 x)) "")<br />     (command "text" "bc" (polar py2 (* pi 0) (/ 5 x)) (/ 2.5 x) 0 (rtos (/ (cadr py2) 1000.0) 2 2))<br />     (setq py1 (polar py1 (* pi 0.5) (/ 100 x))<br />         py2 (polar py2 (* pi 0.5) (/ 100 x))<br />     )<br />   )<br />   ))<br /> <br />   ;;;画坐标十字  <br />   (if (or (>= nx 1) (>= ny 1))(progn<br />   (setq pyx (list (* (1+ (fix (/(car p1)(/ 100 x))))(/ 100 x))<br />       (* (1+ (fix (/(cadr p1)(/ 100 x))))(/ 100 x))));;;起始十字位置<br />     (repeat ny<br />       (setq pxy pyx)<br />        (repeat nx<br />         (command "line" (polar pxy (* pi 1) (/ 5 x)) (polar pxy (* pi 0) (/ 5 x))"")<br />         (command "line" (polar pxy (* pi 0.5) (/ 5 x)) (polar pxy (* pi 1.5) (/ 5 x))"")<br />         (setq pxy (list (+ (car pxy)(/ 100 x))(cadr pxy)))<br />     )<br />     (setq pyx (list (car pyx)(+ (cadr pyx)(/ 100 x))))<br />   )<br />   ))<br />   <br /> ;;恢复设置<br />     (command "_undo" "_e");;活动编组结束<br />   (mapcar 'eval sysvarlst);恢复变量设置  <br />   (setq *error* *olderror*);;恢复出错函数<br />   (setq  *olderror* nil);;<br />   (princ)<br /> )<br /> ;;;<br /> ;;;-----------------------------------------------------------------<br /> ;;;<br />

caogis

地质平面图有用吧

caogis

在作地质平面图时有大作用

hehaidizhi

有错误啊，支持什么版本cad?