批量提取图案填充高程点高程坐标
本帖最后由 树櫴希德 于 2014-9-19 18:33 编辑由于在有些地形图中，软件生成高程点时点位不像CASS那样是个INSERT，也不像SCS那样是个POINT,有些是HATCH 有些是圆弧 园 多段线等等，提取圆弧坐标已经被zzxxoo大神解决，提取图案填充中心坐标由SKG123大神程序+q2大神代码合并而成，在此感谢2位大神！
(defun c:TQWZZB()
(princ "\n选择所需输出的点（point）:")
(setq ss (ssget '((0 . "hatch")) ));;选取坐标点
(setq n (sslength ss ));计算坐标点数量
(setq ff (open (getfiled "文件保存为" "f:/" "dat" 1) "w"));保存路径
(setq i 0)
(repeat n
(setq spt (ssname ss i ))
;(setq ept (entget spt))
;(setq pzx (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10))(entget (car (entsel))))))
(setq pzx (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10))(entget spt))))
(setq lxyz (list (nth 0 (cadr pzx)) (nth 1 (cadr pzx)) (nth 2 (car pzx)) ))
(setq sx (rtos (nth 1 lxyz)));将坐标值实数转换成字符
(setq sy (rtos (nth 0 lxyz)))
(setq sz (rtos (nth 2 lxyz)))
(setq i1 (+ i 1));计算点序号
(setq sn (rtos i1 2 0));将序号实数转换成字符
(setq sxyz (strcat sn",,"sy ","sx","sz))
(write-line sxyz ff)
(setq i (+ i 1))
);repeat
(close ff)
)
(prompt "*只适合HATCH << 命令:TQWZZB >> *输出格式（点号,, Y，X，Z）**")
(prin1)
;(if (= (cdr (assoc 0 ept)) "TEXT")
; (progn
(setq lxyz (cdr (assoc 10ept)))
;(setq sx (rtos (nth 1 lxyz)));将坐标值实数转换成字符
;(setq sy (rtos (nth 0 lxyz)))
;(setq sz (rtos (nth 2 lxyz)))
;(setq i1 (+ i 1));计算点序号
; (setq sn (rtos i1 2 0));将序号实数转换成字符
;(setq sxyz (strcat sn",,"sy ","sx","sz))
; (write-line sxyz ff)
;)
; )
在此奉上zzxxoo大神提取圆弧圆心坐标程序和提取图案填充测试图
(ALERT "明经论坛zzxxoo ")
(defun c:plyxzb(/ wjm fff ptlst i)
(setq wjm (getfiled "请指定要保存的坐标文件" "e:\\" "dat" 1))
(setq fff (open wjm "w"))
(if (setq ss (ssget '((0 . "ARC,CIRCLE")))) (progn
(setq ptlst (list))
(repeat (setq i (sslength ss))
(setq ptlst (cons(cdr(assoc 10 (entget(ssname ss (setq i (1- i)))))) ptlst))
)
ptlst
))
(setq i 0)
(repeat (length ptlst)
(setq ent1 (nth i ptlst))
(write-line (strcat (itoa i) ",,"(rtos (car ent1) 2 3) "," (rtos (cadr ent1) 2 3) "," (rtos (caddr ent1) 2 3)) fff)
(setq i (1+ i))
)
(close fff)
)
请大家热烈讨论 @[树櫴希德]四川
【话唠】LLSheng_73■■■(275988734) 22:58:25
(defun hatchxyz(e)
(setq e(vl-remove-if'(lambda(x)(/=(car x)10))(entget e)))
(list(cadr(cdadr e))(caddr(cdadr e))(last(car e))))
【话唠】LLSheng_73■■■(275988734)18:51:06
HATCH图元的第一个10组最后一个数值(z)和第二个数值的前两个数值(x y)
合并成了( x y z)
谢谢73哥
支持下，图案填充高程点是啥软件生成的？ 73哥版本
(defun hatchxyz(e)(setq e(vl-remove-if'(lambda(x)(/=(car x)10))(entget e)))
(list(cadr(cdadr e))(car(cdadr e))(last(car e))))
(defun c:TQWZZB()
(princ "\n选择所需输出的点（point）:")
(setq ss (ssget '((0 . "hatch")) ));;选取坐标点
(setq n (sslength ss ));计算坐标点数量
(setq ff (open (getfiled "文件保存为" "f:/" "dat" 1) "w"));保存路径
(setq i 0)
(repeat n
(setq spt (ssname ss i ))
;(setq ept (entget spt))
(setq lxyz (hatchxyz spt))
(setq sx (rtos (nth 1 lxyz)));将坐标值实数转换成字符
(setq sy (rtos (nth 0 lxyz)))
(setq sh (rtos (/ (nth 2 lxyz) 1000)))
(setq i1 (+ i 1));计算点序号
(setq sn (rtos i1 2 0));将序号实数转换成字符
(setq sxyz (strcat sn",,"sx ","sy","sh))
(write-line sxyz ff)
(setq i (+ i 1))
);repeat
(close ff)
)
(prompt "*只适合TEXT点 << 命令:TQWZZB >> *输出格式（点号,, Y，X，Z）**")
(prin1)
;(if (= (cdr (assoc 0 ept)) "TEXT")
; (progn
(setq lxyz (cdr (assoc 10ept)))
;(setq sx (rtos (nth 1 lxyz)));将坐标值实数转换成字符
;(setq sy (rtos (nth 0 lxyz)))
;(setq sz (rtos (nth 2 lxyz)))
;(setq i1 (+ i 1));计算点序号
; (setq sn (rtos i1 2 0));将序号实数转换成字符
;(setq sxyz (strcat sn",,"sy ","sx","sz))
; (write-line sxyz ff)
;)
; )
论坛老是跟新浪微博脱钩 树櫴希德 发表于 2014-9-19 20:08 static/image/common/back.gif
@[树櫴希德]四川
【话唠】LLSheng_73■■■(275988734) 22:58:25
(defun hatchxyz(e)
来个山寨版的：
(defun HATCHxyz(e)
(setq e(entget e)p(nth 18 e)
p(list(cadr p)(caddr p)(last(nth 9 e))))
)
热心人就是多啊 搞测量的不多啊支持了 强烈支持
页:
[1]