|
本人对lisp的了解仅仅是皮毛，求助论坛达人！万分感谢！ 手里有一个计算钢筋工程量的小程序（也是以前网上下载的)，以前我们用R14可以正常运行，但是现在版本升级到了CAD2002or2004可以正常导入，命令运行也没问题，就是出不了结果出来，请求达人指点一下！原程序如下： ;;钢筋表计算程序。
;;输入直径、单根长、根数。
;;命令：ＣＡ -- 计算钢筋表。
;;命令：ＤＴＷ -- 由直径计算单位重。
;;命令：ＣＡＴ -- 计算钢筋总重。 (defun ca_main()
(princ (strcat "\n\n当前为" ca:row "列模式; 长度单位 " ca:c_m "；列间距 " (rtos ca:h_ 2 1) "; 文本字高 " (rtos ca:hh 2 2) "; 对齐方式 " ca:jm "。\n"))
(initget 1 "U N C F H J")
(setq pt1 (getpoint (strcat "列数N/单位U/变更列间距C/自由列间距F/文本字高H/对齐方式J/<给出钢筋总长" ca:jm "对齐点>: ")))
(cond
((= pt1 "U")
(if (= ca:c_m "mm") (setq ca:c_m "mm" ca:cmm 0.001) (setq ca:c_m "mm" ca:cmm 0.001))
(ca_main)
)
((= pt1 "N")
(if (= ca:r_w 3) (setq ca:r_w 2 ca:row "二") (setq ca:r_w 3 ca:row "三"))
(ca_main)
)
((= pt1 "C")
(setq c (getdist (strcat "\n给定列间距< " (rtos ca:h_ 2 1)" >: ")))
(if (/= c nil) (setq ca:h_ c))
(ca_main)
)
((= pt1 "F")
(setq n6_ 0)
(if (= ca:r_w 3)
(progn
(initget 1)
(setq ptx1 (car (getpoint (strcat "\n给出钢筋总长" ca:jm "对齐点: "))))
(initget 1)
(setq ptx2 (car (getpoint (strcat "\n给出钢筋单位重" ca:jm "对齐点: "))))
(initget 1)
(setq ptx3 (car (getpoint (strcat "\n给出钢筋总重" ca:jm "对齐点: "))))
)
(progn
(initget 1)
(setq ptx1 (car (getpoint (strcat "\n给出钢筋总长" ca:jm "对齐点: "))))
(initget 1)
(setq ptx3 (car (getpoint (strcat "\n给出钢筋总重" ca:jm "对齐点: "))))
)
)
)
((= pt1 "H")
(setq c (getdist (strcat "\n给定字高< " (rtos ca:hh 2 2)" >: ")))
(if (/= c nil) (progn (setq ca:hh c) (setvar "textsize" c)))
(ca_main)
)
((= pt1 "J")
(setq ca:j_m (rem (1+ ca:j_m) 3))
(cond
((= ca:j_m 0) (setq ca:jm "左"))
((= ca:j_m 1) (setq ca:jm "中"))
((= ca:j_m 2) (setq ca:jm "右"))
(t nil)
)
(ca_main)
)
(t
(setq n6_ 0)
(if (= ca:r_w 3)
(setq ptx1 (car pt1)
ptx2 (+ ptx1 (* 0.95 ca:h_))
ptx3 (+ ptx1 (* 2.0 ca:h_))
)
(setq ptx1 (car pt1)
ptx3 (+ ptx1 (* 1.0 ca:h_))
)
)
)
)
(while (> l1 0)
(ca_smax se1 l1) (setq e01 e20 n1 (ca_f (cdr (assoc 1 e01))) se1 se0)
(ca_smax se2 l1) (setq e02 e20 n2 (ca_n (cdr (assoc 1 e02))) se2 se0)
(ca_smax se3 l1) (setq e03 e20 n3 (ca_n (cdr (assoc 1 e03))) se3 se0)
(setq l1 (sslength se1)
y (/ (+ (caddr(assoc 10 e01)) (caddr(assoc 10 e02))
(caddr(assoc 10 e03))) 3)
)
(setq pt1(list ptx1 y 0)
pt2(list ptx2 y 0)
pt3(list ptx3 y 0)
)
(setq n4 (rtos (* n3 n2 ca:cmm) 2 2)
n5 (rtos (* pi n1 n1 0.0019625) 2 3)
n6 (rtos (* (atof n5) (atof n4)) 2 2)
n6_(+ n6_ (atof n6))
)
(ca_mktext n4 pt1)
(if (= ca:r_w 3) (ca_mktext n5 pt2))
(ca_mktext n6 pt3)
)
) (defun ca_prw(/ p_w)
(setq pt (getpoint (strcat "\n合计钢筋总重" ca:jm "对齐点: ")))
(if (/= pt nil)
(ca_mktext (rtos n6_ 2 2) pt)
(progn
(initget "Yes No")
(setq p_w (getkword "\n取消合计总重？ Yes or <No>?"))
(if (/= p_w "Yes")
(ca_prw)
)
)
)
) (defun ca_f(e1)
(cond
((and (> (ascii e1) 48)(<= (ascii e1) 57)) e1)
((= (ascii e1) 37)
(setq e1(substr e1 3))
(cond
((= (ascii e1) 49) (setq e1 (substr e1 4)))
(t (setq e1 (substr e1 2)))
)
)
(t (setq e1 (substr e1 2)))
)
(setq e1 (atof e1))
) (defun ca_n(e1 / t1 nt nt1)
(setq nt "" nt1 "")
(while (/= e1 "")
(setq t1 (substr e1 1 1) e1 (substr e1 2))
(if (or (= t1 ".") (and (>= (ascii t1) 48) (<= (ascii t1) 57)))
(setq nt1 (strcat nt1 t1))
(progn
(if (or (= t1 "x") (= t1 "X")) (setq t1 "*"))
(cond
((= (ascii nt1) 46) (setq nt1 (strcat "0" nt1)))
((= (type (read nt1)) 'INT) (setq nt1 (strcat nt1 ".0")))
(t nil)
)
(setq nt (strcat nt nt1 t1) nt1 "")
)
)
)
(if (/= nt1 "")
(progn
(cond
((= (ascii nt1) 46) (setq nt1 (strcat "0" nt1)))
((= (type (read nt1)) 'INT) (setq nt1 (strcat nt1 ".0")))
(t nil)
)
(setq nt (strcat nt nt1))
)
(setq nt (strcat nt nt1))
)
(setq e1 (c:cal nt))
) (defun ca_smax(se l_ / e10 y0 i e1 e2 yi y0)
(setq e10 (ssname se 0)
e20 (entget e10)
y0 (caddr(assoc 10 e20))
i 0 se0 (ssadd)
)
(if (/= l_ 1)
(repeat (- l_ 1)
(setq i (+ i 1)
e1 (ssname se i)
e2 (entget e1)
yi (caddr(assoc 10 e2))
)
(if (> yi y0)
(progn (ssadd e10 se0) (setq e20 e2 y0 yi e10 e1))
(ssadd e1 se0)
)
)
)
) (defun ca_mktext(str pt10 / sty)
(entmake
(list
'(0 . "TEXT")
(cons 1 str)
(cons 10 pt10)
(cons 11 pt10)
(cons 7 (setq sty (getvar "textstyle")))
(cons 40 ca:hh)
(assoc 41 (tblsearch "style" sty))
(cons 51 (cdr (assoc 50 (tblsearch "style" sty))))
'(71 . 0)
(cons 72 ca:j_m)
; (cons 73 :j2)
)
)
)
(defun c:ca(/ se0 se1 se2 se3 l1 l2 l3 a_ e01 e02 e03 n6_ e20 y olderr c
pt1 pt2 pt3 ptx1 ptx2 ptx3 n1 n2 n3 n4 n5 n6)
(setq olderr *error*)
(defun *error*(s)
(if (= s "Function cancelled") (setq *error* olderr))
(princ)
)
(command "color" (getvar "cecolor"))
(prompt "\n拾取钢筋直径: ")
(setq a_ 2 se1 (ssget '((0 . "TEXT"))))
(if (/= se1 nil) (progn (setq l1 (sslength se1) a_ 0)) (princ "\n未选择物体."))
(while (= a_ 0)
(prompt "\n拾取钢筋长度: ")
(setq se2 (ssget '((0 . "TEXT"))))
(if (/= se2 nil) (setq l2 (sslength se2)))
(if (= l2 l1) (setq a_ 1) (princ "\n选择集长度不同! "))
)
(if (/= se1 nil) (setq a_ 0))
(while (= a_ 0)
(prompt "\n拾取钢筋根数: ")
(setq se3 (ssget '((0 . "TEXT"))))
(if (/= se3 nil) (setq l3 (sslength se3)))
(if (= l3 l1) (setq a_ 1) (princ "\n选择集长度不同! "))
)
(if (= ca:cmm nil) (setq ca:cmm 0.001 ca:c_m "mm"))
(if (= ca:r_w nil) (setq ca:r_w 3 ca:row "三"))
(if (= ca:jm nil) (setq ca:jm "右" ca:j_m 2))
(if (= ca:hh nil) (setq ca:hh (getvar "textsize")))
(if (= ca:h_ nil)
(progn
(if (>= ca:hh 1.0)
(setq ca:h_ (* (expt 10.0 (+ (fix (/ (log ca:hh) (log 10))) 1)) 2.0))
(setq ca:h_ (* (expt 10.0 (fix (/ (log ca:hh) (log 10)))) 2.0))
)
)
)
(if (= a_ 1) (progn (ca_main) (ca_prw)))
(setq *error* olderr)
(princ)
)
(defun ca_dw()
(princ (strcat "\n当前文本字高 " (rtos ca:hh 2 2) "; 对齐方式 " ca:jm ".\n"))
(initget 1 "H J")
(setq pt1 (getpoint (strcat "\n文本字高H/对齐方式J/<给出钢筋" t1 ca:jm "对齐点: >")))
(cond
((= pt1 "H")
(setq c (getdist (strcat "\n给定字高< " (rtos ca:hh 2 2)" >: ")))
(if (/= c nil) (progn (setq ca:hh c) (setvar "textsize" c)))
(ca_dw)
)
((= pt1 "J")
(setq ca:j_m (rem (1+ ca:j_m) 3))
(cond
((= ca:j_m 0) (setq ca:jm "左"))
((= ca:j_m 1) (setq ca:jm "中"))
((= ca:j_m 2) (setq ca:jm "右"))
(t nil)
)
(ca_dw)
)
(t nil)
)
) (defun c:dtw(/ se1 se0 l1 pt1 e01 e02 y n1 e20 t1 olderr)
(setq olderr *error*)
(defun *error*(s)
(if (= s "Function cancelled") (setq *error* olderr))
(princ)
)
(command "color" (getvar "cecolor"))
(princ "\n拾取钢筋直径:")
(setq se1 (ssget '((0 . "TEXT"))))
(if (/= se1 nil)
(progn
(setq l1 (sslength se1) t1 "单位重")
(if (= ca:jm nil) (setq ca:jm "右" ca:j_m 2))
(if (= ca:hh nil) (setq ca:hh (getvar "textsize")))
(ca_dw)
(while (> l1 0)
(ca_smax se1 l1)
(setq e01 e20
se1 se0
l1 (sslength se1)
y (caddr(assoc 10 e01))
n1 (ca_f (cdr(assoc 1 e01)))
pt1(list (car pt1) y 0)
n1 (rtos (* pi n1 n1 0.0019625) 2 3)
)
(ca_mktext n1 pt1)
)
)
(princ "\n未选择物体.")
)
(setq *error* olderr)
(princ)
) (defun c:cat(/ se1 l1 pt1 e01 n1 i olderr)
(setq olderr *error*)
(defun *error*(s)
(if (= s "Function cancelled") (setq *error* olderr))
(princ)
)
(command "color" (getvar "cecolor"))
(princ "\n拾取钢筋重量:")
(setq se1 (ssget '((0 . "TEXT"))))
(if (/= se1 nil)
(progn
(setq l1 (sslength se1) t1 "合计总重")
(if (= ca:jm nil) (setq ca:jm "右" ca:j_m 2))
(if (= ca:hh nil) (setq ca:hh (getvar "textsize")))
(ca_dw)
(setq i -1 nt 0)
(repeat l1
(setq i (+ i 1)
e01 (entget(ssname se1 i))
n1 (atof (cdr(assoc 1 e01)))
nt (+ nt n1)
)
)
(ca_mktext (rtos nt 2 2) pt1)
)
(princ "\n未选择物体.")
)
(setq *error* olderr)
(princ)
) (if (= (type c:cal) 'LIST) (arxload "geomcal.arx"))
(princ "\n**************************************************************")
(princ "\n CA -- 钢筋表计算。 ")
(princ " DTW -- 钢筋单位重计算。")
(princ " CAT -- 钢筋重量合计。")
(princ)
| 
发表于 2008-3-5 18:30
置顶卡
变色卡
显身卡
发表于 2008-3-6 09:04