坐标网格程序,还没有调试完毕,欢迎大家一起来打酱油~~~
本帖最后由 77077 于 2014-7-10 09:23 编辑坐标网格程序,还没有调试完毕,欢迎大家一起来打酱油~~~(defun makeline (p1 p2)
(entmakex (list '(0 . "line") (cons 10 p1) (cons 11 p2)))
)
(defun maketext (str pt ang h)
(entmakex
(list '(0 . "text") (cons 1 str) (cons 10 pt) (cons 50 ang) (cons 40 h))
)
)
(defun c:zbwg ()
(setq os (getvar "osmode"))
(setq P1 (getpoint "输入左下角坐标：")
P2 (getcorner P1 "\n输入右上角坐标：")
BL (getint "输入间隔距离<50>:")
)
(if (not bl) (setq bl 50))
(setq len-x (- (car p2) (car p1))
len-y (- (cadr p2) (cadr p1))
remx (rem (car p1) bl)
remy (rem (cadr p1) bl)
xwgs (fix (/ len-x bl))
ywgs (fix (/ len-y bl))
i 1
ii 1
zg (* bl 0.1)
)
(setvar "osmode" 0)
(repeat xwgs
(setq pt1 (polar p1 0 (- (* bl i) remx))
pt2 (polar pt1 (* pi 0.5) len-y))
(makeline pt1 pt2)
(setq str (strcat "X=" (rtos (car pt1) 2 0)))
(setq str-pt1 (polar pt1 pi zg)
str-pt2 (polar pt2 pi zg)
str-pt2 (polar str-pt2 (* pi 1.5) (* (strlen str) zg))
)
(maketext str str-pt1 (* pi 0.5) zg)
(maketext str str-pt2 (* pi 0.5) zg)
(setq i (1+ i))
)
(repeat ywgs
(setq pt1 (polar p1 (* pi 0.5) (- (* bl ii) remy))
pt2 (polar pt1 0 len-x))
(makeline pt1 pt2)
(setq str (strcat "Y=" (rtos (cadr pt1) 2 0)))
(setq str-pt1 (polar pt1 (* pi 0.5) zg)
str-pt2 (polar pt2 (* pi 0.5) zg)
str-pt2 (polar str-pt2 pi (* (strlen str) zg))
)
(maketext str str-pt1 0 zg)
(maketext str str-pt2 0 zg)
(setq ii (1+ ii))
)
(setvar "osmode" os)
(princ)
) 打酱油的路过……
xyp1964 发表于 2014-7-10 08:41 static/image/common/back.gif
院长,帮我改一下呗.
1.程序开始,保存所有系统变量到C:\\ACADVAR.TXT,程序结束,读取C:\\ACADVAR.TXT恢复变量
2.求个函数,判断图层是否存在,若不存在添加图层(MKlay 图层名 颜色 线型)
RE: 坐标网格程序,还没有调试完毕,欢迎大家一起来打酱油~~~
77077 发表于 2014-7-14 04:46 static/image/common/back.gif院长,帮我改一下呗.
2.求个函数,判断图层是否存在,若不存在添加图层(MKlay 图层名 颜色 线型) ...
(setq lay (tblsearch "layer" "多边形编号"))
(if (= lay nil)
(command "layer" "n" "多边形编号" "c" "4" "多边形编号" "")
) 真牛逼，很需要哈。 厉害！ 很好！改进
页:
[1]