从CASS中提取高程点坐标输出至文本（图面连续拾取，可框选）【原】

skg123 · 发表于 2012-12-17 11:52:18

本帖最后由 skg123 于 2014-8-30 15:30 编辑

CASS有高程点坐标提取的功能，但它是全部提取，用户有时候想选择性的提取需要的部分高程点就不方便了，针对该问题，别人编辑了一个小程序。可以在图上直接碰选高程点（不能框选）讲坐标输出至文本，文本格式为CASS “XXX.dat”样式。
命令：gcdtq
《附件》

2014年8月30修改，修改后增加高程点编码，可以框选，并且可以连续作业
(defun c:tqgc(/ p1 p2 ss sn si i x y e fw)
(prompt "**从CASS中提取高程点，请在命令行输入 tqgc , ** Esc 取消退出")
(setq n 0)
(setq sn 0)
(setq zh 0)
(setq ff (open (getfiled "文件保存为" "f:/" "dat" 1) "a"))
(while
(setq word (getstring "\请输入高程点编码:"))
(setq ss(ssget (list(cons 8 "GCD")(cons 2 "GC200"))))
(if ss(progn
(setq fw(open "d:\\ex.dat" "w"))
(setq sn(sslength ss))
(setq i 0)
(while(< i sn)
(setq si (ssname ss i))
;=====提取坐标=====2014-08-30======
(setq pt(cdr(assoc 10 (entget si))))
(setq x(rtos(car pt)2 3) y(rtos(cadr pt)2 3) e(rtos(caddr pt)2 3))
(princ(strcat (itoa (+ n (+ 1 i )))","word"," x "," y "," e "\n") ff)
(setq i (+ 1 i))
);end while
(setq n (+ n sn ));序号累加
);end while
(close ff)
)
)
(princ)
)

ku-8510 · 发表于 2021-10-25 14:47:47

赞一个，谢谢

zyhandw · 发表于 2012-12-17 16:22:25

比较简单的程序，况且是别人的，还是不收币的好些！
哪怕是编译成fas，给大家用下也好

Gu_xl · 发表于 2012-12-17 16:30:57

程序有待改进提高！
1、高程点应该为框选
2、while循环退出采用esc退出不太好
3、文件结束没有用(close ff) 关闭！

skg123 · 发表于 2012-12-17 18:21:34

zyhandw 发表于 2012-12-17 16:22
比较简单的程序，况且是别人的，还是不收币的好些！
哪怕是编译成fas，给大家用下也好

这个是我自己编了2天才编好的，
(while(not(setq en (entsel"\n选择高程点<Esc退出>: "))) ;没选中就一直让选择，取消键退出
en
); 这个是借鉴人家的，但也不能直接用，其他是自己编的。

skg123 · 发表于 2012-12-17 18:23:16

本帖最后由 skg123 于 2012-12-17 18:35 编辑

Gu_xl 发表于 2012-12-17 16:30
程序有待改进提高！
1、高程点应该为框选
2、while循环退出采用esc退出不太好

多谢你的意见。我也不想用esc退出，但是右键退出我现在的的水平编不好。
请指点一下框选用 ssget 怎样才能获取高程点的坐标值？

Gu_xl · 发表于 2012-12-18 09:01:56

本帖最后由 Gu_xl 于 2012-12-18 09:03 编辑

skg123 发表于 2012-12-17 18:23
多谢你的意见。我也不想用esc退出，但是右键退出我现在的的水平编不好。
请指点一下框选用 ssget 怎样 ...

修改如下：

;By 2012-12-17 宜昌
(defun c:gcdtq()
(setvar "cmdecho" 0) ;指令执行过程不响应
(setq file (getfiled "文件保存为" "" "dat" 1))
(if (findfile file)
(setq ff (open file "a"))
(setq ff (open file "w"))
)
(setq n 0)
(while (setq ss (ssget '((0 . "insert") (2 . "gc200"))))
(repeat (setq k (sslength ss))
(setq en (ssname ss (setq k (1- k))))
(setq n(+ n 1))
(setq pn(rtos n 2 0))
(setq en_data (entget EN)) ;取得元体资料列表
(setq pt (cdr (assoc 10 en_data))) ;求得高程点坐标pt
(setq py(rtos (nth 1 pt)2 3));提取测量坐标Y值
(setq px(rtos (nth 0 pt)2 3));提取测量坐标X值
(setq pz(rtos (nth 2 pt)2 3));提取测量坐标Z值
(setq sxyz (strcat pn",,"px "," py "," pz))
(write-line sxyz ff)
)
)
(prompt "***** << C:gcdtq >> ***提取高程点坐标输出为CASS格式****")
(close ff)
(prin1);
)
;从CASS中连续单选高程点，并将高程点数据输出到文本，解决CASS不能有选择性的拾取高程点。

fanqinwei · 发表于 2012-12-22 09:59:45

这个CASS本身自带，不必再去编写

004 · 发表于 2013-1-8 17:34:12

ZB(导出坐标).LSP程序源文件,修改程序用
ZB(导出坐标).VLX编译好的文件,供加载,工作.

加载程序
菜单栏  工具-AutoLisp-加载...点击"启动组"点击"添加"选择"ZB(导出坐标).VLX"文件,,添加完成后关闭对话框即可.(第一次添加好后以后就可以直接使用)

在命令行输入"zb"即可启动程序,按提示操作即可

对选择的圆放入"导出层"并把颜色设置成了随层
可以连续选取不同图层,不同颜色的多种类型的圆
按e键可退出程序编辑发现的问题
按x接着选择圆
按d导出"导出层"上所有圆的圆心坐标,文件放在c盘下,并和当前文件名相似.

QQ:278416560

;;;wkq004  QQ:278416560 2009.02.24
(vl-load-com)
(defun c:tt (/       CENTER  COLOR DIRECTORY       E       E2
      E2L    EEL    EL       FILENAME       FL       LAYERNAME
      MYACAD  N       SS       SS2    SS3    SSE    START
      STRING  XH1    XH2
      )
  (setvar "cmdecho" 0)
  (setq osmode (getvar "osmode"))
  (setvar "osmode" 0)
  (command "layer" "M" "导出层" "C" 8 "" "")
  (setq xh1 1)
  (setq xh2 1)
  (while (= 1 xh1)
(while (= 1 xh2)
   (princ "\n[结束选择(空格/回车/右键)]请点选要导出的圆:")
   (if
(setq ss3 (ssget ":S" '((0 . "TEXT"))))
   (progn
   (setq sse (ssname ss3 0))
   (setq eel (entget sse))
   (setq layername (cdr (assoc 8 eel)))
   (if (setq color (cdr (assoc 62 eel)))
      (setq ss2
      (ssget
      "X"
      (list (cons 0 "TEXT")
      (cons 8 layername)
      (cons 62 color)
      )
      )
      )
      (setq
         ss2
(ssget "X" (list (cons 0 "TEXT") (cons 8 layername)))
      )
   )
   (setq n 0)
   (command ".undo" "begin")
   (repeat (sslength ss2)
      (setq e2 (ssname ss2 n))
      (setq e2l (entget e2))
      (setq e2l (subst (cons 8 "导出层") (assoc 8 e2l) e2l))
      (setq e2l (subst (cons 62 256) (assoc 62 e2l) e2l))
      (entmod e2l)
      (setq n (1+ n))
   )
   (command ".undo" "end")
   )
   (progn
   (setq xh2 0)
   )
   )
)
(initget 1 "D X E")
(setq start (getreal "\n[退出(E)继续选择(X)]导出请输入(D):"))
(if (= "D" start)
   (progn
(if
   (setq ss (ssget "X" '((8 . "导出层") (0 . "TEXT"))))
   (progn
      (setq myacad (vlax-get-acad-object))
      (setq filename (vl-filename-base (vla-get-caption myacad)))
      (while (vl-file-systime (strcat "c:/" filename ".txt"))
         (setq filename (strcat filename "-1"))
      )
      (setq directory (strcat "c:/" filename ".txt"))
      (setq fl (open directory "w"))
      (setq n 0)
      (repeat (sslength ss)
         (setq e (ssname ss n))
         (setq el (entget e))
         (setq n (1+ n))
         (setq center (cdr (assoc 10 el)))
         (setq text (cdr (assoc 1 el)))
         (setq
   string (strcat (setq text (cdr (assoc 1 el)))
",,"
(rtos (car center) 2 3)
","
(rtos (cadr center) 2 3)
","
(rtos (last center) 2 3)
)
         )
         (write-line string fl)
      )
      (close fl)
      (princ (strcat "\n坐标导出成功" directory))
      (setq xh1 0)
   )
   (progn
      (princ "\n在\"导出层\"内没有圆可供导出,程序终止!!")
      (setq xh1 0)
   )
)
   )
   (progn
(if (= "X" start)
   (setq xh2 1)
   (setq xh1 0)
)
   )
)
  )
  (setvar "cmdecho" 1)
  (setvar "osmode" osmode)
  (princ)
)

gzxl · 发表于 2013-1-8 18:51:51

多谢源码

linshiyin2 · 发表于 2013-8-2 10:44:13

挺实用的，尤其是cass的属性没有后自己提取数据。

账号		自动登录	找回密码
密码			注册

从CASS中提取高程点坐标输出至文本（图面连续拾取，可框选）【原】

本帖子中包含更多资源

相关帖子

本帖子中包含更多资源