经纬度坐标标注及导出

下北良

看看学习一下

yaogang_cl

一个铜板，只要好用就值。谢谢

yaogang_cl

可以试用么，好用的话可以考虑购买

zhouzhiy

谢谢楼主分享！

rounwei

要注册

yjd

看起来很实用。

wzg

1. ;坐标标注 wzg356 2014.9.12
   
2. ;2015.11.21改版
   
3. (defun c:bzb ( / newerr *olderror* EntmakeLWPL entmaketext n hzt mjd x2y pt0 p1 p2
   
4.         xpt ypt l pt2 xqz yqz en0 ent0 en1 ent1 en2 ent2 en3 ent3 gr gr-model gr-value pt1)
   
5.         ;自定义新的出错函数
   
6.     (defun newerr (msg)
   
7.             (command "_erase" en0 en1 en2 en3  "")
   
8.             (command "_undo" "_e")
   
9.             (mapcar 'eval sysvarlst);恢复变量设置
   
10.             (if *olderror* (setq *error* *olderror*  *olderror* nil)) ;_ 恢复*error*函数
    
11.             (if (not (member msg '(nil "函数被取消" ";错误:quit / exit abort")))
    
12.                     (princ (strcat ";错误:" msg))
    
13.                 )
    
14.         )
    
15. ;============
    
16.         ;;创建多义线
    
17. (defun EntmakeLWPL (vertices Lw / elist seg)
    
18.   (setq elist
    
19.      (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline")
    
20.             (cons 90 (length vertices))
    
21.             (cons 70 0)
    
22.             (cons 38 (caddr (car vertices)))
    
23.             (cons 40 Lw)
    
24.             (cons 41 Lw)
    
25.             (cons 43 Lw)
    
26.      )
    
27.   )
    
28.   (foreach seg vertices (setq elist (append elist (list (cons 10 seg) (cons 42 0)))))
    
29.   (entmake elist)
    
30. )
    
31. ;============
    
32. (defun entmaketext (pt str textheigh)
    
33.      (entmakex (list '(0 . "text") (cons 1 str) (cons 7 "MY_ST")(cons 10 pt)
    
34.              (cons 40 textheigh)(cons 41 0.8)(cons 11 pt) (cons 72 0) (cons 73 2)))
    
35. )
    
36.         ;;系统设置
    
37.         (command "undo" "be");;命令编组开始
    
38.         (setq sysvarlst(mapcar (function (lambda (n) (list 'setvar n (getvar n))))
    
39.             '( "osmode" "cmdecho"  "plinewid" "TEXTSIZE" "textstyle" "dimzin")));保存系统变量
    
40.         (setq *olderror* *error*);保存出错函数
    
41.         (setq  *error* newerr);设置自定义出错函数       
    
42.         (setvar "cmdecho" 0);;;关闭命令响应
    
43.         (setvar "OSMODE" 675);;;改变捕捉模式
    
44.         (setvar "dimzin" 1);;;数字不消零
    
45.        
    
46.         (if (= (Tblsearch "style" "MY_ST") nil)
    
47.                 (command "-style" "MY_ST" "宋体" 0 0.8 0 "n" "n");;;文字样式
    
48.         )       
    
49.     (setvar "textstyle" "MY_ST")
    
50. 
    
51.     ;;初始数据
    
52.     (if xyrecords
    
53.             (mapcar 'set (list 'hzt 'mjd 'x2y 'xqz 'yqz)
    
54.                     (list (atof (nth 0 xyrecords))
    
55.                             (atoi (nth 1 xyrecords))
    
56.                             (atoi (nth 2 xyrecords))
    
57.                             (nth 3 xyrecords)
    
58.                             (nth 4 xyrecords)
    
59.                     )
    
60.                 )
    
61.                 (mapcar 'set (list 'hzt 'mjd 'x2y 'xqz 'yqz)
    
62.                (list ( getvar "TEXTSIZE") 2 0 "x=" "y=")
    
63.             )                       
    
64.         )   
    
65.        
    
66.         ;开始标注
    
67.         (princ (strcat "\n当前文字高度" (rtos hzt 2 2)(if (= x2y 1) ", x/y值互换" "")))
    
68.         (setq pt0 nil)
    
69.         (initget 1 "S  ")
    
70.         (setq pt0 (getpoint "\n点取标注点位置【或设置参数(S)】:"))       
    
71.         (cond                                               
    
72.                         ((= (type pt0) 'list)                               
    
73.                                 (setq p1 (polar pt0 (* pi -0.5) (* hzt  0.7)))
    
74.                                 (setq p2 (polar pt0 (* pi  0.5) (* hzt  0.7)))
    
75.                                 (setq xpt (rtos (cadr pt0) 2 mjd)
    
76.                                           ypt (rtos (car pt0) 2 mjd))
    
77.                                 (setq l (* 0.72 hzt (max (strlen xpt) (strlen ypt))));依据字高的横线长度
    
78.                                 (setq pt2 (polar pt0 0 l))
    
79.                                 (entmakex (list
    
80.                                         '(0 . "line") (cons 10 (trans pt0 1 0)) (cons 11 (polar (trans pt0 1 0) 0 1.0))));引线
    
81.                                 (setq en0 (entlast) ent0 (entget en0))
    
82.                                 (entmakex (list '(0 . "line") (cons 10 (trans pt0 1 0)) (cons 11 (trans pt2 1 0))));引线横
    
83.                                 (setq en1 (entlast)        ent1 (entget en1))
    
84.                                 (if (= x2y 1)
    
85.                                         (entmaketext (trans p2 1 0) (strcat xqz ypt) hzt)
    
86.                                         (entmaketext (trans p2 1 0) (strcat xqz xpt) hzt)
    
87.                                 )
    
88.                                 (setq en2 (entlast) ent2 (entget en2))
    
89.                                 (if (= x2y 1)
    
90.                                         (entmaketext (trans p1 1 0) (strcat yqz xpt) hzt)
    
91.                                         (entmaketext (trans p1 1 0) (strcat yqz ypt) hzt)
    
92.                                 )
    
93.                                 (setq en3 (entlast) ent3 (entget en3))
    
94.                                 (setq gr 0 gr-model 0 gr-value 0 );;gr-model必须归零
    
95.                                 (while (/= gr-model 3) ;鼠标左键
    
96.                                         (setq gr (grread T 8)
    
97.                                                   gr-model (car gr)
    
98.                                                   gr-value (cadr gr));鼠标位置
    
99.                                         (if        (and gr (=  gr-model 5));鼠标移动
    
100.                                                 (progn
     
101.                                                         (setq pt1 gr-value)
     
102.                                                         (if(>= (car gr-value)(car pt0));如果文字点在坐标点右边
     
103.                                                             (setq pt2 (polar pt1 0 l)
     
104.                                                                       p1 (polar pt1 (* pi -0.5) (* hzt  0.7))
     
105.                                                                       p2 (polar pt1 (* pi  0.5) (* hzt  0.7)))
     
106.                                                                 (setq pt2 (polar pt1 0 (* -1.0 l))
     
107.                                                                           p1 (polar pt2 (* pi -0.5) (* hzt  0.7))
     
108.                                                                           p2 (polar pt2 (* pi  0.5) (* hzt  0.7)));文字点在坐标点左边
     
109.                                                         )
     
110.                                                         (setq  ent0 (subst (cons 11 (trans pt1 1 0)) (assoc 11 ent0) ent0);根据鼠标位置调整图元位置
     
111.                                                                ent1 (subst (cons 10 (trans pt1 1 0)) (assoc 10 ent1) ent1)
     
112.                                                                ent1 (subst (cons 11 (trans pt2 1 0)) (assoc 11 ent1) ent1)
     
113.                                                                ent2 (subst (cons 11 (trans p2 1 0)) (assoc 11 ent2) ent2)
     
114.                                                                ent3 (subst (cons 11 (trans p1 1 0)) (assoc 11 ent3) ent3))
     
115.                                                         (entmod ent0)(entmod ent1);重生成图元
     
116.                                                         (entmod ent2)(entmod ent3)
     
117.                                                 )
     
118.                                         )
     
119.                                 )
     
120.                                 (entdel en0)(entdel  en1);删除直线引线
     
121.                                 (EntmakeLWPL (list (trans pt0 1 0) (trans pt1 1 0) (trans pt2 1 0)) 0.1);以多线段重画引线
     
122.                                 (c:bzb)
     
123.                         )
     
124.                         ((= pt0 "S")
     
125.                                 (setq xyrecords(set_bzbdate))               
     
126.                                 (c:bzb)
     
127.                         )
     
128.                         ((= pt0 "") nil)
     
129.                         (t (c:bzb))
     
130.         )       
     
131.         ;;恢复设置
     
132.         (command "_undo" "_e");;活动编组结束
     
133.         (mapcar 'eval sysvarlst);恢复变量设置
     
134.         (setq *error* *olderror*);;恢复出错函数
     
135.         (princ)  
     
136. );defun
     
137. 
     
138. ;以下为子函数
     
139. (defun set_bzbdate ( / get_date tuoqiulst mjdlst dcl_id dd);通过对话框设置参数       
     
140.         (defun get_date ()
     
141.                 (mapcar '(lambda (x) (get_tile x))
     
142.                 (list "bzzg" "mjd" "x2y" "xqz" "yqz"))
     
143.         )
     
144.         (setq mjdlst (list "0" "0.0" "0.00" "0.000"))
     
145.         (setq dcl_id (load_dialog (make-bzbdcl)))
     
146.         (new_dialog "bzbdcl" dcl_id)       
     
147.         (start_list "mjd" 3) (mapcar 'add_list mjdlst)(end_list)
     
148.         (if (= xyrecords nil)
     
149.                 (setq xyrecords(list (rtos ( getvar "TEXTSIZE") 2 2) "2" "0" "x=" "y=")))
     
150.    (mapcar '(lambda (x y) (set_tile x y))(list "bzzg" "mjd" "x2y" "xqz" "yqz")xyrecords)       
     
151.         (action_tile "accept" "(if (not(member (type (read (get_tile "bzzg"))) (list 'INT 'REAL)))(alert "字高非数字！") (progn(setq xyrecords(get_date))(done_dialog 1)))")               
     
152.         (setq dd (start_dialog))
     
153.         (unload_dialog dcl_id)
     
154.         (if (= dd 1)xyrecords)
     
155.                        
     
156. )
     
157. 
     
158. 
     
159. (defun make-bzbdcl  ( / lst_str str file f)
     
160.                 (setq lst_str '(
     
161. "bzbdcl:dialog {"
     
162. "    label = "标注坐标" ;"
     
163. "    :boxed_column {"
     
164. "        :edit_box {"
     
165. "            edit_width = 10 ;"
     
166. "            key = "xqz" ;"
     
167. "            label = "x前缀" ;"
     
168. "        }"
     
169. "        :edit_box {"
     
170. "            edit_width = 10 ;"
     
171. "            key = "yqz" ;"
     
172. "            label = "y前缀" ;"
     
173. "        }"
     
174. "        :edit_box {"
     
175. "            edit_width = 10 ;"
     
176. "            key = "bzzg" ;"
     
177. "            label = "文字高度" ;"
     
178. "        }"
     
179. "        :popup_list {"
     
180. "            edit_width = 9.2 ;"
     
181. "            key = "mjd" ;"
     
182. "            label = "精度  " ;"
     
183. "        }"
     
184. "    }"
     
185. "    :boxed_column {"
     
186. "        :toggle {"
     
187. "            key = "x2y" ;"
     
188. "            label = "x/y值互换(前缀不变)" ;"
     
189. "        }"
     
190. "    }"
     
191. "    :spacer {}"
     
192. "    ok_only;"
     
193. "    :text {"
     
194. "        label = "by1047048660" ;"
     
195. "    }"
     
196. "}"
     
197.                     )
     
198.     )
     
199.     (setq file (vl-filename-mktemp "DclTemp.dcl"))
     
200.     (setq f (open file "w"))
     
201.     (foreach str lst_str
     
202.         (princ "\n" f)
     
203.         (princ str f)
     
204.     )
     
205.     (close f)
     
206.     ;;返回
     
207.     file
     
208. )
     
209. ;;;=================================================================*
     
210. (princ)

复制代码

ykerty

你好 成果不错  好好学习了

18200354887

谢谢 分享

wxn80

a769795772 发表于 2017-11-25 17:22
工程应用里面不是可以标注么，坐标坪高

CASS9.0以上软件可以标注经纬度坐标，但是现在的9.0破解版都破解不完全，点击经纬度标注命令行显示的是未知命令。