从CASS中提取高程点坐标输出至文本（图面连续拾取，可框选）【原】
本帖最后由 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)
)
赞一个，谢谢 比较简单的程序，况且是别人的，还是不收币的好些！
哪怕是编译成fas，给大家用下也好 程序有待改进提高！
1、高程点应该为框选
2、while循环退出采用esc退出不太好
3、文件结束没有用(close ff) 关闭！ zyhandw 发表于 2012-12-17 16:22 static/image/common/back.gif
比较简单的程序，况且是别人的，还是不收币的好些！
哪怕是编译成fas，给大家用下也好
这个是我自己编了2天才编好的，
(while(not(setq en (entsel"\n选择高程点<Esc退出>: ")));没选中就一直让选择，取消键退出
en
); 这个是借鉴人家的，但也不能直接用，其他是自己编的。 本帖最后由 skg123 于 2012-12-17 18:35 编辑
Gu_xl 发表于 2012-12-17 16:30 http://bbs.mjtd.com/static/image/common/back.gif
程序有待改进提高！
1、高程点应该为框选
2、while循环退出采用esc退出不太好
多谢你的意见。我也不想用esc退出，但是右键退出我现在的的水平编不好。
请指点一下 框选用 ssget 怎样才能获取 高程点的坐标值？
本帖最后由 Gu_xl 于 2012-12-18 09:03 编辑
skg123 发表于 2012-12-17 18:23 http://bbs.mjtd.com/static/image/common/back.gif
多谢你的意见。我也不想用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不能有选择性的拾取高程点。
这个CASS本身自带，不必再去编写 ZB(导出坐标).LSP程序源文件,修改程序用
ZB(导出坐标).VLX编译好的文件,供加载,工作.
加载程序
菜单栏工具-AutoLisp-加载...点击"启动组"点击"添加"选择"ZB(导出坐标).VLX"文件,,添加完成后关闭对话框即可.(第一次添加好后以后就可以直接使用)
在命令行输入"zb"即可启动程序,按提示操作即可
对选择的圆放入"导出层"并把颜色设置成了随层
可以连续选取不同图层,不同颜色的多种类型的圆
按e键可退出程序编辑发现的问题
按x接着选择圆
按d导出"导出层"上所有圆的圆心坐标,文件放在c盘下,并和当前文件名相似.
QQ:278416560
;;;wkq004QQ:278416560 2009.02.24
(vl-load-com)
(defun c:tt (/ CENTERCOLOR DIRECTORY E E2
E2L EEL EL FILENAME FL LAYERNAME
MYACADN SS SS2 SS3 SSE START
STRINGXH1 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)
) 多谢源码
挺实用的，尤其是cass的属性没有后自己提取数据。