xy自由图框，测量、地质用得上
本帖最后由 wzg356 于 2014-11-19 00:46 编辑;;;
;;; 命令：BGTK
;;;
;;; 在地形图上插入图框（包括坐标十字符号）
;;;
;;; 作者：凉开水 2005.09.25
;;;WZG356 改于20140916,完善出错处理及十字丝判断退出
;;;-----------------------------------------------------------------
;;;
(defun c:BGTK ( / newerr *olderror* x p1 p2 p3 p4 nx ny px1 px2 py1 py2 pyx pxy)
;自定义新的出错函数
(defun newerr (msg)
(mapcar 'eval sysvarlst);恢复变量设置
(if *olderror* (setq *error* *olderror**olderror* nil)) ;_ 恢复*error*函数
(if (not (member msg '(nil "函数被取消" ";错误:quit / exit abort")))
(princ (strcat ";错误:" msg))
)
)
;;系统设置
(command "undo" "be");;命令编组开始
(setq sysvarlst(mapcar (function (lambda (n) (list 'setvar n (getvar n))))
'( "osmode" "cmdecho" "OSNAPCOORD" "dimzin" "plinewid" ))
);保存系统变量
(setq *olderror* *error*);保存出错函数
(setq*error* newerr);设置自定义出错函数
(setvar "cmdecho" 0);;;关闭命令响应
(setvar "OSNAPCOORD" 1);;;坐标数据优先级设为：键盘输入替代对象捕捉设置
(setvar "OSMODE" 687);;;改变捕捉模式
(setvar "dimzin" 0);;;不对主单位值作消零处理
(if (= (Tblsearch "style" "MY_ST") nil)
(command "-style" "MY_ST" "宋体" 0 0.8 0 "n" "n");;;文字样式
)
(command "textstyle" "MY_ST")
(princ "\n假定CAD中绘制比例为1:1千")
(if (not (setq x (getreal "\n输入出图比例,1代表1:1千,10代表1:1万，以此类推<1>: ")))(setq x 1.0))
;;;四角坐标点
(setq x (/ 1.0 x)
pt1 (getpoint "\n指定第一角点: ")
pt2 (getcorner pt1 "\n指定另一角点: ")
)
(if (> (car pt1) (car pt2))
(if(> (cadr pt1) (cadr pt2))
(setq p1 pt2
p2 (list (car pt1) (cadr pt2))
p3 pt1
p4 (list (car pt2) (cadr pt1))
)
(setq p1 (list (car pt2) (cadr pt1))
p2 pt1
p3 (list (car pt1) (cadr pt2))
p4 pt2
)
)
(if(> (cadr pt1) (cadr pt2))
(setq p1 (list (car pt1) (cadr pt2))
p2 pt2
p3 (list (car pt2) (cadr pt1))
p4 pt1
)
(setq p1 pt1
p2 (list (car pt2) (cadr pt1))
p3 pt2
p4 (list (car pt1) (cadr pt2))
)
)
)
(command "zoom" "w" (polar p1 (* pi 1.25) (* 2 (/ 20 x)))
(polar p3 (* pi 0.25) (* 2 (/ 20 x)))
)
(command "rectang" p4 p2);;;画内框
;;;画外框
(command "pline" (list 0 0 0) "w" (/ 0.4 x) (/ 0.4 x) "");;;定义线宽
(command "pline" (list (-(car p1) (/ 10 x))(-(cadr p1) (/ 10 x)))
(list (+(car p2) (/ 10 x))(-(cadr p2) (/ 10 x)))
(list (+(car p3) (/ 10 x))(+(cadr p3) (/ 10 x)))
(list (-(car p4) (/ 10 x))(+(cadr p4) (/ 10 x)))
"c"
)
;;;画四角短线
(command "line" p1 (polar p1 (* pi 1) (/ 10 x)) "")
(command "line" p1 (polar p1 (* pi 1.5) (/ 10 x)) "")
(command "line" p2 (polar p2 (* pi 0) (/ 10 x)) "")
(command "line" p2 (polar p2 (* pi 1.5) (/ 10 x)) "")
(command "line" p3 (polar p3 (* pi 0) (/ 10 x)) "")
(command "line" p3 (polar p3 (* pi 0.5) (/ 10 x)) "")
(command "line" p4 (polar p4 (* pi 0.5) (/ 10 x)) "")
(command "line" p4 (polar p4 (* pi 1) (/ 10 x)) "")
;;;写四角坐标值
(command "text" "br" (polar p1 (* pi 1.687) (/ 5.78 x)) (/ 2.5 x) 0 (rtos (/ (car p1) 1000.0) 2 2))
(command "text" "bc" (polar p1 (* pi 1) (/ 5 x)) (/ 2.5 x) 0 (rtos (/ (cadr p1) 1000.0) 2 2))
(command "text" "br" (polar p2 (* pi 1.687) (/ 5.78 x)) (/ 2.5 x) 0 (rtos (/ (car p2) 1000.0) 2 2))
(command "text" "bc" (polar p2 (* pi 0) (/ 5 x)) (/ 2.5 x) 0 (rtos (/ (cadr p2) 1000.0) 2 2))
(command "text" "br" (polar p3 (* pi 0.2618) (/ 4.776 x)) (/ 2.5 x) 0 (rtos (/ (car p3) 1000.0) 2 2))
(command "text" "bc" (polar p3 (* pi 0) (/ 5 x)) (/ 2.5 x) 0 (rtos (/ (cadr p3) 1000.0) 2 2))
(command "text" "br" (polar p4 (* pi 0.2618) (/ 4.776 x)) (/ 2.5 x) 0 (rtos (/ (car p4) 1000.0) 2 2))
(command "text" "bc" (polar p4 (* pi 1) (/ 5 x)) (/ 2.5 x) 0 (rtos (/ (cadr p4) 1000.0) 2 2))
;;;坐标十字的行列数
(setq nx (- (fix (/(car p2)(/ 100 x)))(fix (/( car p1)(/ 100 x))))
ny (- (fix (/(cadr p4)(/ 100 x)))(fix (/( cadr p1)(/ 100 x))))
)
;;;写内外框间坐标值
(if (>=nx 1)(progn
(setq px1 (list (* (1+ (fix (/(car p1)(/ 100 x))))(/ 100 x))(cadr p1))
px2 (list (* (1+ (fix (/(car p4)(/ 100 x))))(/ 100 x))(cadr p4)))
(repeat nx
(command "line" px1 (polar px1 (* pi 1.5) (/ 10 x)) "")
(command "text" "br" (polar px1 (* pi 1.687) (/ 5.78 x)) (/ 2.5 x) 0 (rtos (/ (car px1) 1000.0) 2 2))
(command "line" px2 (polar px2 (* pi 0.5) (/ 10 x)) "")
(command "text" "br" (polar px2 (* pi 0.2618) (/ 4.776 x)) (/ 2.5 x) 0 (rtos (/ (car px2) 1000.0) 2 2))
(setq px1 (list (+ (car px1)(/ 100 x))(cadr px1))
px2 (list (+ (car px2)(/ 100 x))(cadr px2)))
)
))
(if (>=ny 1)(progn
(setq py1 (list (car p1)(* (1+ (fix (/(cadr p1)(/ 100 x))))(/ 100 x)))
py2 (list (car p2)(* (1+ (fix (/(cadr p2)(/ 100 x))))(/ 100 x))))
(repeat ny
(command "line" py1 (polar py1 (* pi 1) (/ 10 x)) "")
(command "text" "bc" (polar py1 (* pi 1) (/ 5 x)) (/ 2.5 x) 0 (rtos (/ (cadr py1) 1000.0) 2 2))
(command "line" py2 (polar py2 (* pi 0) (/ 10 x)) "")
(command "text" "bc" (polar py2 (* pi 0) (/ 5 x)) (/ 2.5 x) 0 (rtos (/ (cadr py2) 1000.0) 2 2))
(setq py1 (polar py1 (* pi 0.5) (/ 100 x))
py2 (polar py2 (* pi 0.5) (/ 100 x))
)
)
))
;;;画坐标十字
(if (or (>= nx 1) (>= ny 1))(progn
(setq pyx (list (* (1+ (fix (/(car p1)(/ 100 x))))(/ 100 x))
(* (1+ (fix (/(cadr p1)(/ 100 x))))(/ 100 x))));;;起始十字位置
(repeat ny
(setq pxy pyx)
(repeat nx
(command "line" (polar pxy (* pi 1) (/ 5 x)) (polar pxy (* pi 0) (/ 5 x))"")
(command "line" (polar pxy (* pi 0.5) (/ 5 x)) (polar pxy (* pi 1.5) (/ 5 x))"")
(setq pxy (list (+ (car pxy)(/ 100 x))(cadr pxy)))
)
(setq pyx (list (car pyx)(+ (cadr pyx)(/ 100 x))))
)
))
;;恢复设置
(command "_undo" "_e");;活动编组结束
(mapcar 'eval sysvarlst);恢复变量设置
(setq *error* *olderror*);;恢复出错函数
(setq*olderror* nil);;
(princ)
)
;;;
;;;-----------------------------------------------------------------
;;;
地质平面图有用吧 在作地质平面图时有大作用 有错误啊，支持什么版本cad?
页:
[1]