坐标网格程序,还没有调试完毕,欢迎大家一起来打酱油~~~

77077 · 发表于 2014-7-9 18:04

本帖最后由 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)
)

(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) 
)

风树 · 发表于 2014-7-9 19:27

打酱油的路过……

xyp1964 · 发表于 2014-7-10 08:41

77077 · 发表于 2014-7-10 09:46

xyp1964 发表于 2014-7-10 08:41

院长,帮我改一下呗.
1.程序开始,保存所有系统变量到C:\\ACADVAR.TXT,程序结束,读取C:\\ACADVAR.TXT恢复变量
2.求个函数,判断图层是否存在,若不存在添加图层(MKlay 图层名颜色线型)

vlisp2012 · 发表于 2014-7-10 13:10

77077 发表于 2014-7-14 04:46
院长,帮我改一下呗.
2.求个函数,判断图层是否存在,若不存在添加图层(MKlay 图层名颜色线型) ...

(setq lay (tblsearch "layer" "多边形编号"))
(if (= lay nil)
(command "layer" "n" "多边形编号" "c" "4" "多边形编号" "")
)

rhett_sky · 发表于 2015-1-9 21:16

真牛逼，很需要哈。

guankuiwu · 发表于 2021-5-17 14:52

厉害！

guankuiwu · 发表于 2021-5-17 16:20

很好！改进

账号		自动登录	找回密码
密码			注册

[源码] 坐标网格程序,还没有调试完毕,欢迎大家一起来打酱油~~~

相关帖子

本帖子中包含更多资源

RE: 坐标网格程序,还没有调试完毕,欢迎大家一起来打酱油~~~