[LISP程序]：图幅号计算（天津）

shongdragon3 · 发表于 2004-11-23 10:10:38

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

(defun c:tfh(/ s1 b1 x y tfh zb1 zb2)
   (command "osmode" "0")
   (command "cmdecho" "0")
   (prompt "\n图上指定点用来计算图幅号并绘制图廓线")
   (setq s1 (getpoint"\n图幅内点点："))
   (setq s2 (getstring"\n 比例尺(500,1000,2000,5000,10000):"))
   (if (or (= s1 nil) (= s2 nil))(exit))
   (setq x (car s1))
   (setq y (cadr s1))
   (setq tfh (tfhjs y x b1))
   (if (= b1 "500") (progn
            (setq x(* (fix (/ x 250) 250))
            (setq y(* (fix (/ y 200) 200))
            (setq zb1(list x y))
            (setq zb2(list (+ x 250) (+ y 200)))
                     )
   (if (= b1 "1000") (progn
            (setq x(* (fix (/ x 500) 500))
            (setq y(* (fix (/ y 400) 400))
            (setq zb1(list x y))
            (setq zb2(list (+ x 500) (+ y 400)))
                     )
   (if (= b1 "2000") (progn
            (setq x(* (fix (/ x 1000 1000))
            (setq y(* (fix (/ y 800) 800))
            (setq zb1(list x y))
            (setq zb2(list (+ x 1000) (+ y 800)))
                     )
   (if (= b1 "5000") (progn
            (setq x(* (fix (/ x 2500) 2500))
            (setq y(* (fix (/ y 2000) 2000))
            (setq zb1(list x y))
            (setq zb2(list (+ x 2500) (+ y 2000)))
                     )
   (if (= b1 "10000") (progn
            (setq x(* (fix (/ x 5000) 5000))
            (setq y(* (fix (/ y 4000) 4000))
            (setq zb1(list x y))
            (setq zb2(list (+ x 5000) (+ y 4000)))
                     )
   (setq b1 (/ (atof b1) 1000))
   (command "layer" "m" "tk" "")
   (command "text" (list (+ x 50) (+ y 50)) "10" "0" tfh)
   (command "rectang" zb1 zb2)
   (command "layer" "s" "0" "")
   (command "zoom" "e")
   (princ)
)
(defun tfhjs(x y blc / zxjy zxjx zxjp xk yk xx yx xxh xt yt hwb ywx ywy wbh wbtfh ywtfh  wqtfh tfh1)
   (setq xk (* (fix(/ (fix(/ x 1000)) 4)) 4))
   (setq yk (* (fix(/ (fix(/ y 1000)) 5)) 5))
   (setq ywx(rtos xk 2 0))
   (setq ywy(rtos yk 2 0))
   (setq ywtfh (strcat  ywx "-" ywy))
   (if (= blc "2000")
         (progn
               (setq xx (-x (* xk 1000)))
               (setq yy (-y (* yk 1000)))
               (setq m (-5 (fix (/ xx 800)))
               (setq n (+1 (fix (/ yy 1000)))
               (setq hlq (+ (* (- m 1) 5) n))
               (setq lqh(rtos hlq 2 0))
               (setq lqtfh (strcat  ywx "-" ywy "-" lqh))
         )
      )
      (if (or (= blc "500") (= blc "5000") )
         (progn
               (setq xx (/ (- x (* xk 1000)) 2000))
               (setq yy (/ (- y (* yk 1000)) 2500))
               (if (and (> xx 1) (< yy 1))
                  (progn
                  (setq xxh "I")
                  (setq xt (* (- xx 1) 2000))
                  (setq yt (* yy 2500))
                  )
               )
               (if (and (> xx 1) (> yy 1))
                  (progn
                  (setq xxh "II")
                  (setq xt (* (- xx 1) 2000))
                  (setq yt (* (- yy 1) 2500))
                  )
               )
               (if (and (< xx 1) (< yy 1))
                  (progn
                  (setq xxh "III")
                  (setq xt (* xx 2000))
                  (setq yt (* yy 2500))
                  )
               )
               (if (and (< xx 1) (> yy 1))
                  (progn
                  (setq xxh "IV")
                  (setq xt (* xx 2000))
                  (setq yt (* (- yy 1) 2500))
                  )
               )
               (setq hwb (+ (* 10 (- 9 (fix (/ xt 200)))) (+ (fix (/ yt 250)) 1)))
               (setq wbh(rtos hwb 2 0))
               (setq wqtfh (strcat  ywx "-" ywy "-" xxh))
               (setq wbtfh (strcat  ywx "-" ywy "-" xxh "-"wbh))
               )
            )
            (if (= blc "10000") (setq tfh1 ywtfh))
            (if (= blc "5000")  (setq tfh1 wqtfh))
            (if (= blc "2000")  (setq tfh1 lqtfh))
            (if (= blc "500") (setq tfh1 wbtfh))
            (setq tfh tfh1)
   )

wwpp44 · 发表于 2004-12-5 20:47:25

出发吧，音乐响起，梦随太阳升腾。
我们将用羽翼继续打量世界！

550066 · 发表于 2004-12-9 16:35:23

能说明一下吗

zmw0211 · 发表于 2004-12-11 14:25:34

很好!顶以下.

emailme · 发表于 2004-12-13 21:14:07

顶一下

andymong · 发表于 2004-12-22 12:41:09

说一下有什么用

ufo263 · 发表于 2004-12-23 15:05:56

请加上说明吧，那样有需要的朋友就更有目的下载了，最好有图片步骤说明，谢谢！

teatree · 发表于 2005-1-12 08:54:58

是用来画图框的吗

蓝静如水 · 发表于 2005-1-25 13:43:24

我复制了楼主的程序，加载到CAD。提示——错误: 输入的列表有缺陷。请问是什么问题？

etjedi · 发表于 2005-1-28 13:56:12

大大，可否详细说明一下，谢了

ml886003 · 发表于 2005-3-11 19:20:35

楼主如果在的话，请说明一下，帮帮我们！

feathern · 发表于 2005-3-16 14:21:17

怎么用？放CAD里面吗？说明一下可以吗？

nuomandi · 发表于 2005-3-18 13:21:04

有问题

wang3212 · 发表于 2005-3-18 15:09:41

这里真是太好啦。我是一个初学者，正烦着呢。

rungang2002 · 发表于 2005-3-26 22:20:14

干什么用呢

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

[LISP程序]：图幅号计算（天津）

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

支持