地信网论坛

 找回密码
 立即注册

QQ登录

只需一步,快速开始

免费视频|新人指南|答学员问|投诉删帖

禁止上传涉密资料|赚取铜板|附件下载

查看: 3866|回复: 56
收起左侧

[软件] 经纬度坐标标注及导出

    [复制链接]

101

主题

1万

铜板

79

好友

地信院士

Rank: 15Rank: 15Rank: 15Rank: 15Rank: 15

积分
2145

灌水勋章荣誉会员勋章活跃勋章地信专家组VIP勋章贡献勋章5周年纪念勋章成就学员勋章

QQ
发表于 2017-4-5 08:33 | 显示全部楼层 |阅读模式
“家乡”主题作品征集大赛

马上注册地信网,享受更多功能,学习更多知识,成就人生精彩!

您需要 登录 才可以下载或查看,没有帐号?立即注册

x


经纬度坐标导出及标注.zip (2.55 KB, 下载次数: 415)

3

主题

180

铜板

0

好友

技术员

Rank: 3Rank: 3

积分
78
发表于 2018-11-26 19:32 | 显示全部楼层
  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.     (if xyrecords
  52.             (mapcar 'set (list 'hzt 'mjd 'x2y 'xqz 'yqz)
  53.                     (list (atof (nth 0 xyrecords))
  54.                             (atoi (nth 1 xyrecords))
  55.                             (atoi (nth 2 xyrecords))
  56.                             (nth 3 xyrecords)
  57.                             (nth 4 xyrecords)
  58.                     )
  59.                 )
  60.                 (mapcar 'set (list 'hzt 'mjd 'x2y 'xqz 'yqz)
  61.                (list ( getvar "TEXTSIZE") 2 0 "x=" "y=")
  62.             )                       
  63.         )   
  64.        
  65.         ;开始标注
  66.         (princ (strcat "\n当前文字高度" (rtos hzt 2 2)(if (= x2y 1) ", x/y值互换" "")))
  67.         (setq pt0 nil)
  68.         (initget 1 "S  ")
  69.         (setq pt0 (getpoint "\n点取标注点位置【或设置参数(S)】:"))       
  70.         (cond                                               
  71.                         ((= (type pt0) 'list)                               
  72.                                 (setq p1 (polar pt0 (* pi -0.5) (* hzt  0.7)))
  73.                                 (setq p2 (polar pt0 (* pi  0.5) (* hzt  0.7)))
  74.                                 (setq xpt (rtos (cadr pt0) 2 mjd)
  75.                                           ypt (rtos (car pt0) 2 mjd))
  76.                                 (setq l (* 0.72 hzt (max (strlen xpt) (strlen ypt))));依据字高的横线长度
  77.                                 (setq pt2 (polar pt0 0 l))
  78.                                 (entmakex (list
  79.                                         '(0 . "line") (cons 10 (trans pt0 1 0)) (cons 11 (polar (trans pt0 1 0) 0 1.0))));引线
  80.                                 (setq en0 (entlast) ent0 (entget en0))
  81.                                 (entmakex (list '(0 . "line") (cons 10 (trans pt0 1 0)) (cons 11 (trans pt2 1 0))));引线横
  82.                                 (setq en1 (entlast)        ent1 (entget en1))
  83.                                 (if (= x2y 1)
  84.                                         (entmaketext (trans p2 1 0) (strcat xqz ypt) hzt)
  85.                                         (entmaketext (trans p2 1 0) (strcat xqz xpt) hzt)
  86.                                 )
  87.                                 (setq en2 (entlast) ent2 (entget en2))
  88.                                 (if (= x2y 1)
  89.                                         (entmaketext (trans p1 1 0) (strcat yqz xpt) hzt)
  90.                                         (entmaketext (trans p1 1 0) (strcat yqz ypt) hzt)
  91.                                 )
  92.                                 (setq en3 (entlast) ent3 (entget en3))
  93.                                 (setq gr 0 gr-model 0 gr-value 0 );;gr-model必须归零
  94.                                 (while (/= gr-model 3) ;鼠标左键
  95.                                         (setq gr (grread T 8)
  96.                                                   gr-model (car gr)
  97.                                                   gr-value (cadr gr));鼠标位置
  98.                                         (if        (and gr (=  gr-model 5));鼠标移动
  99.                                                 (progn
  100.                                                         (setq pt1 gr-value)
  101.                                                         (if(>= (car gr-value)(car pt0));如果文字点在坐标点右边
  102.                                                             (setq pt2 (polar pt1 0 l)
  103.                                                                       p1 (polar pt1 (* pi -0.5) (* hzt  0.7))
  104.                                                                       p2 (polar pt1 (* pi  0.5) (* hzt  0.7)))
  105.                                                                 (setq pt2 (polar pt1 0 (* -1.0 l))
  106.                                                                           p1 (polar pt2 (* pi -0.5) (* hzt  0.7))
  107.                                                                           p2 (polar pt2 (* pi  0.5) (* hzt  0.7)));文字点在坐标点左边
  108.                                                         )
  109.                                                         (setq  ent0 (subst (cons 11 (trans pt1 1 0)) (assoc 11 ent0) ent0);根据鼠标位置调整图元位置
  110.                                                                ent1 (subst (cons 10 (trans pt1 1 0)) (assoc 10 ent1) ent1)
  111.                                                                ent1 (subst (cons 11 (trans pt2 1 0)) (assoc 11 ent1) ent1)
  112.                                                                ent2 (subst (cons 11 (trans p2 1 0)) (assoc 11 ent2) ent2)
  113.                                                                ent3 (subst (cons 11 (trans p1 1 0)) (assoc 11 ent3) ent3))
  114.                                                         (entmod ent0)(entmod ent1);重生成图元
  115.                                                         (entmod ent2)(entmod ent3)
  116.                                                 )
  117.                                         )
  118.                                 )
  119.                                 (entdel en0)(entdel  en1);删除直线引线
  120.                                 (EntmakeLWPL (list (trans pt0 1 0) (trans pt1 1 0) (trans pt2 1 0)) 0.1);以多线段重画引线
  121.                                 (c:bzb)
  122.                         )
  123.                         ((= pt0 "S")
  124.                                 (setq xyrecords(set_bzbdate))               
  125.                                 (c:bzb)
  126.                         )
  127.                         ((= pt0 "") nil)
  128.                         (t (c:bzb))
  129.         )       
  130.         ;;恢复设置
  131.         (command "_undo" "_e");;活动编组结束
  132.         (mapcar 'eval sysvarlst);恢复变量设置
  133.         (setq *error* *olderror*);;恢复出错函数
  134.         (princ)  
  135. );defun

  136. ;以下为子函数
  137. (defun set_bzbdate ( / get_date tuoqiulst mjdlst dcl_id dd);通过对话框设置参数       
  138.         (defun get_date ()
  139.                 (mapcar '(lambda (x) (get_tile x))
  140.                 (list "bzzg" "mjd" "x2y" "xqz" "yqz"))
  141.         )
  142.         (setq mjdlst (list "0" "0.0" "0.00" "0.000"))
  143.         (setq dcl_id (load_dialog (make-bzbdcl)))
  144.         (new_dialog "bzbdcl" dcl_id)       
  145.         (start_list "mjd" 3) (mapcar 'add_list mjdlst)(end_list)
  146.         (if (= xyrecords nil)
  147.                 (setq xyrecords(list (rtos ( getvar "TEXTSIZE") 2 2) "2" "0" "x=" "y=")))
  148.    (mapcar '(lambda (x y) (set_tile x y))(list "bzzg" "mjd" "x2y" "xqz" "yqz")xyrecords)       
  149.         (action_tile "accept" "(if (not(member (type (read (get_tile \"bzzg\"))) (list 'INT 'REAL)))(alert \"字高非数字!\") (progn(setq xyrecords(get_date))(done_dialog 1)))")               
  150.         (setq dd (start_dialog))
  151.         (unload_dialog dcl_id)
  152.         (if (= dd 1)xyrecords)
  153.                        
  154. )


  155. (defun make-bzbdcl  ( / lst_str str file f)
  156.                 (setq lst_str '(
  157. "bzbdcl:dialog {"
  158. "    label = \"标注坐标\" ;"
  159. "    :boxed_column {"
  160. "        :edit_box {"
  161. "            edit_width = 10 ;"
  162. "            key = \"xqz\" ;"
  163. "            label = \"x前缀\" ;"
  164. "        }"
  165. "        :edit_box {"
  166. "            edit_width = 10 ;"
  167. "            key = \"yqz\" ;"
  168. "            label = \"y前缀\" ;"
  169. "        }"
  170. "        :edit_box {"
  171. "            edit_width = 10 ;"
  172. "            key = \"bzzg\" ;"
  173. "            label = \"文字高度\" ;"
  174. "        }"
  175. "        :popup_list {"
  176. "            edit_width = 9.2 ;"
  177. "            key = \"mjd\" ;"
  178. "            label = \"精度  \" ;"
  179. "        }"
  180. "    }"
  181. "    :boxed_column {"
  182. "        :toggle {"
  183. "            key = \"x2y\" ;"
  184. "            label = \"x/y值互换(前缀不变)\" ;"
  185. "        }"
  186. "    }"
  187. "    :spacer {}"
  188. "    ok_only;"
  189. "    :text {"
  190. "        label = \"by1047048660\" ;"
  191. "    }"
  192. "}"
  193.                     )
  194.     )
  195.     (setq file (vl-filename-mktemp "DclTemp.dcl"))
  196.     (setq f (open file "w"))
  197.     (foreach str lst_str
  198.         (princ "\n" f)
  199.         (princ str f)
  200.     )
  201.     (close f)
  202.     ;;返回
  203.     file
  204. )
  205. ;;;=================================================================*
  206. (princ)
复制代码

回复 支持 1 反对 0

使用道具 举报

0

主题

1201

铜板

2

好友

助理工程师

Rank: 5Rank: 5

积分
205
发表于 2017-4-5 09:22 | 显示全部楼层
地信网论坛版规和新人指南
,,,,,,
回复 支持 反对

使用道具 举报

2

主题

3027

铜板

1

好友

助理工程师

Rank: 5Rank: 5

积分
242
发表于 2017-4-5 09:27 | 显示全部楼层
一个铜板,只要好用就值。谢谢!
回复 支持 反对

使用道具 举报

0

主题

2702

铜板

15

好友

助理工程师

Rank: 5Rank: 5

积分
159
发表于 2017-4-5 09:34 | 显示全部楼层
地信网论坛发帖规范—规范发帖,方便你我他!
!!!!111111
回复

使用道具 举报

5

主题

8922

铜板

81

好友

地信院士

Rank: 15Rank: 15Rank: 15Rank: 15Rank: 15

积分
2333
发表于 2017-4-5 10:11 | 显示全部楼层
《涉密地质资料管理细则》必读
好好学习             天天向上           
该会员没有填写今日想说内容.
回复 支持 反对

使用道具 举报

0

主题

77

铜板

0

好友

实习生

Rank: 1

积分
5
发表于 2017-4-5 10:25 | 显示全部楼层
快速提高会员级别和总积分的说明与方法
一个铜板,只要好用就值。谢谢!
回复 支持 反对

使用道具 举报

1

主题

750

铜板

3

好友

技术员

Rank: 3Rank: 3

积分
89
发表于 2017-4-5 14:17 | 显示全部楼层
地信网论坛》管理制度(试行
谢谢 分享!
回复

使用道具 举报

0

主题

5041

铜板

0

好友

工程师

Rank: 7Rank: 7Rank: 7

积分
436
发表于 2017-4-6 09:13 | 显示全部楼层
谢谢分享!
回复

使用道具 举报

9

主题

1321

铜板

8

好友

高级工程师

Rank: 9Rank: 9Rank: 9

积分
835
发表于 2017-4-6 17:30 | 显示全部楼层
是通过转换参数计算的椭球坐标吗?
回复 支持 反对

使用道具 举报

14

主题

1万

铜板

30

好友

教授级高工

Rank: 12Rank: 12Rank: 12

积分
1987

爱心勋章地信元老灌水勋章荣誉会员勋章活跃勋章贡献勋章5周年纪念勋章成就学员勋章

发表于 2017-4-7 08:15 | 显示全部楼层
亲爱的楼主你好:请问加载后,如何启动(触发)该插件呢?谢谢!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

土流网招商加盟广告
在线客服

新人指南|地信论坛 ( 湘ICP备14003170号-5 湖南土流信息有限公司 版权所有 关于地信 联系方式 邮箱登陆

湘公网安备 43010302000511号

Powered by Discuz! X3.2

快速回复 返回顶部 返回列表