广东省地质测绘院院长李冰峰程序-打点检查平面
;;打点检查之输出点位坐标(defun c:zdhsc(/ zdh_ss fileneme zdhn len f pp x y xystr)
(setq zdh_ss (ssget "X" (list (cons 0 "point") (cons 8 "zdh"))))
(if zdh_ss (progn
(setq filename (getfiled "输入要保存的数据文件名<.txt>:" "d:/" "txt" 5))
(if filename (progn
(setq zdhn 0 len (sslength zdh_ss))
(setq f (open filename "w"))
(while (< zdhn len)
(setq pp (cdr (assoc '10 (entget (ssname zdh_ss zdhn)))))
(setq x (rtos (cadr pp) 2 3) y (rtos (car pp) 2 3))
(setq zdhn (+ zdhn 1))
(setq xystr (strcat (itoa zdhn) " " x " " y))
(write-line xystr f)
);while
(setq zdh_ss nil)
(close f)
(princ (strcat "\n共输出" (itoa len) "个点的坐标成果，成果文件为:" filename))
);progn
(princ "\n未设置文件名，未进行坐标输出操作。")
);if
);progn
(princ "\n图形中没有任何点位!")
);if
(princ)
);defun
;;---------------------------------------------------------------------------------
(DEFUN sh_ch ( LST /)
(COMMAND "_.ZOOM" "C" LST "1")
)
;;打点检查之形成坐标分析文件
(defun c:ddjc()
(setq filename (getfiled "选择检查点的坐标数据文件名<.txt>:" "" "txt" 0))
(if filename (progn
(setq ddlist nil endk 0 nddlist nil)
(setq f (open filename "r"))
(while (setq ddstr (read-line f))
(setq ddstr (strcat "(" ddstr ")"))
(if (= ddlist nil)
(setq ddlist (list (reverse (read ddstr))))
(setq ddlist (cons (reverse (read ddstr)) ddlist))
);if
);while
(close f)
(if ddlist (progn
(setq ddlist (reverse ddlist) ddnn 0 len (length ddlist))
(if (= ddn nil) (setq ddn 0))
(while (= ddnn 0)
(setq ddnn (getint (strcat "\n共" (itoa len) "个点，请选择从第几个点开始<" (itoa (+ ddn 1)) ">:")))
(if (= ddnn nil) (setq ddnn (+ ddn 1)))
(if (and (> ddnn 0) (< ddnn (+ len 1))) (setq ddn (- ddnn 1)) (setq ddnn 0))
);while
(while (and (< ddn len) (/= endk 1))
(setq po_all (list (reverse (cdr (reverse (nth ddn ddlist))))))
(sh_ch (CAR po_all))
(initget "U S B")
(princ (strcat "\n共" (itoa len) "个点，现在是第" (itoa (+ ddn 1)) "个点。"))
(setq pp (getpoint "\n回到上一点（U）/跳过此点（S）/作标记并跳过此点（B）<采集原坐标点或空回车结束>:"))
(cond (( = pp "U")
(if (/= (+ ddn 1) ddnn) (progn
(setq ddn (- ddn 1))
(if (and nddlist (= (nth 0 (nth 0 nddlist)) (nth 2 (nth ddn ddlist))))
(setq nddlist (cdr nddlist))
);if
);progn
(princ "\已不能回退!")
);if
)
((= pp "S")
(setq ddn (+ ddn 1))
)
((= pp "B")
(setq p0 (reverse (cdr (reverse (nth ddn ddlist)))))
(entmake (list (cons 0 "CIRCLE") (cons 8 "标记") (cons 62 1) (cons 10 p0) (cons 40 0.5)))
(setq ddn (+ ddn 1))
)
((= pp nil)
(initget "Y N")
(setq ddkey (getkword "\n是否是否要结束取点？是（Y）/否（N）<N>:"))
(if (= ddkey "Y") (setq endk 1))
)
((= (type pp) (type (list 1 1)))
(entmake (list (cons 0 "CIRCLE") (cons 8 "0") (cons 62 3) (cons 10 pp) (cons 40 0.05)))
(initget "Y N")
(setq ddkey (getkword "\n是否为小绿色标记圆的点，是（Y）/否（N）<Y>:"))
(command "erase" (entlast) "")
(if (or (= ddkey nil) (= ddkey "Y")) (progn
(setq pp (cons (nth 2 (nth ddn ddlist)) pp))
(if nddlist (setq nddlist (cons pp nddlist)) (setq nddlist (list pp)))
(setq ddn (+ ddn 1))
));if
)
);cond
);while
(if nddlist (progn
(princ (strcat "\n共采集到" (itoa (length nddlist)) "个原坐标点。"))
(setq filename nil nddlist (reverse nddlist))
(initget "X A W")
(setq ddkey (getkword "\n不保存数据退出（X）/追加保存数据（A）/覆盖保存数据（W）<W>:"))
(if (= ddkey nil) (setq ddkey "W"))
(if (= ddkey "W")
(setq filename (getfiled "选择数据文件名<.txt>:" "" "txt" 5))
);if
(if (= ddkey "A")
(setq filename (getfiled "选择数据文件名<.txt>:" "" "txt" 0))
);if
(if filename (progn
(setq zn 0 ddnn 0)
(if (= ddkey "A") (progn
(setq f (open filename "r"))
(while (setq ddstr (read-line f))
(setq zn (+ zn 1))
);while
(close f)
);progn
);if
(setq f (open filename ddkey))
(while (and (/= ddkey "X") (< ddnn (length nddlist)))
(setq pp (nth ddnn nddlist))
(setq n (nth 0 pp))
(setq pp1 (nth (- n 1) ddlist))
(setq ddstr (strcat (itoa (+ ddnn 1 zn)) " " (rtos (nth 1 pp1) 2 3) " " (rtos (nth 0 pp1) 2 3) " " (rtos (nth 2 pp) 2 3) " " (rtos (nth 1 pp) 2 3)))
(write-line ddstr f)
(setq ddnn (+ ddnn 1))
);while
(close f)
(princ (strcat "\n数据已保存在" filename "，文件中共有" (itoa (+ ddnn zn)) "个点的坐标检查数据。"))
);progn
(if (and (/= ddkey "X") (= filename nil)) (princ "\n未选择文件名，数据未保存!") (princ "\n程序已退出，数据未保存!"))
);if
);progn
(princ "\n没有采集到原坐标点!")
);if
);progn
(princ (strcat "\n" filename "中没有坐标数据!"))
);if
);progn
(princ "\n未设置检查点的坐标数据文件，未进行任何操作。")
);if
(princ)
);defun 能讲解一下功能吗？有点每太看懂，最好是配个演示 本帖最后由 scwdb809 于 2015-9-15 14:02 编辑
10多年前的老程序了，发帖人应尊重原代码编写人的劳动成果！ 没有演示，不知道是干嘛用的！ 南方Cass有这个功能 非常谢谢大侠分享 非常谢谢大侠分享
页:
[1]