各位兄弟，你们好！ 帮我看看这个土方计算程序为什么不能用啊，我加载这个程序后，选择闭合线及高程时， 出现什么除数为0，不能生成网格线。望各位测绘兄弟帮我看看，兄弟感谢了 (defun c:tf (/ a nb np hr n i ai b la h hi s p p1)
(princ "选择高程及面积:")
(setq a (ssget '((0 . "text"))))
(setq na 0)
(setq nb 0)
(setq hp 0)
(setq hr 0)
(setq n (sslength a))
(setq i 0)
(repeat n
(setq ai (ssname a i))
(setq i (+ i 1))
(setq b (entget ai))
(setq la (cdr (assoc 8 b)))
(setq h (cdr (assoc 1 b)))
(setq hi (atof h))
(if (or
(= la "YGC")
(= la "ygc")
)
(progn
(setq na (+ na 1))
(setq hp (+ hp hi))
)
)
(if (or
(= la "XGC")
(= la "xgc")
)
(progn
(setq nb (+ nb 1))
(setq hr (+ hr hi))
)
)
(if (or
(= la "MJ")
(= la "mj")
)
(progn
(setq s (substr h 3))
(setq s (atof s))
(setq p (cdr (assoc 10 b)))
(setq p1 (polar p 2 2))
)
)
)
(setq hp (/ hp na))
;(setq hp 11)
(setq hr (/ hr nb))
(setq v 0)
(setq v (* s (- hr hp)))
(setq v (rtos v 2 2))
(setq s (strcat "V=" v))
(setq pt1 (mapcar
'+
pt1
'(0.8 0 0)
)
)
(setq e (list (cons 0 "text") (cons 1 s) (cons 10 p1) (cons 40 0.8)))
(entmake e)
)
(defun c:v ()
(setq a (ssget '((0 . "TEXT"))))
(setq n (sslength a))
(setq i 0)
(setq s 0)
(repeat n
(setq ai (ssname a i))
(setq i (+ i 1))
(setq b (entget ai))
(setq attr (cdr (assoc 0 b)))
(if (= attr "TEXT")
(progn
(setq t (cdr (assoc 1 b)))
(if (< (atof t) 0.000001)
(progn
(setq si (atof (substr t 3)))
(setq s (+ s si))
)
)
)
)
)
(setq p (getpoint "s_location:"))
(setq s (strcat "V=" (rtos s 2 2)))
(command "text" p 1 "" s)
)(defun c:s ()
(setq a (ssget '((0 . "TEXT"))))
(setq n (sslength a))
(setq i 0)
(setq s 0)
(repeat n
(setq ai (ssname a i))
(setq i (+ i 1))
(setq b (entget ai))
(setq attr (cdr (assoc 0 b)))
(if (= attr "TEXT")
(progn
(setq t (cdr (assoc 1 b)))
(if (< (atof t) 0.000001)
(progn
(setq si (atof (substr t 3)))
(setq s (+ s si))
)
)
)
)
)
(setq p (getpoint "s_location:"))
(setq s (strcat "S=" (rtos s 2 2)))
(command "text" p 1 "" s)
)
(defun c:aa (/ p a s)
(setq e (entlast))
(setq p (getpoint "input text point:"))
(command "BOUNDARY" p "")
(if (equal e (entlast))
(alert "BOUNDARY ERROR ！")
(progn
(command "AREA" "O" "LAST")
(entdel (entlast))
(setq a (getvar "AREA"))
;(setq zzza(/ a 666.66667))
;(setq zzza(rtos zzza 2 2))
;(setq zzza(strcat "（合" zzza "亩）"))
(setq s (rtos a 2 2))
(setq s (strcat "S=" S))
;(setq s (strcat s "平方米" zzza))
(command "text" p "0.8" "" s)
)
)
)
(defun c:ygc ()
(setq pt1 (getpoint "输入设计高点位？"))
(setq pt1 (mapcar
'+
pt1
'(0.6 -1.5 0)
)
)
(setq str "7.10")
(setq e (list (cons 0 "text")
(cons 1 str)
(cons 8 "YGC")
(cons 10 pt1)
(cons 40 1)
)
)
(entmake e)
)
(defun c:xgc ()
(setq pt1 (getpoint "点位？"))
(setq pt1 (mapcar
'+
pt1
'(0.6 1.5 0)
)
)
(setq str (getstring "Enter text:"))
(setq e (list (cons 0 "text")
(cons 1 str)
(cons 8 "XGC")
(cons 10 pt1)
(cons 40 1)
)
)
(entmake e)
)
(defun tfxyz (ssent / len k ai g xyz x y z dxfvl vl)
(setq vl '())
(if ssent
(progn
(setq len (sslength ssent)
k 0
)
(repeat len
(setq ai (ssname ssent k)
k (1+ k)
)
(setq g (entget ai))
(setq xyz (cdr (assoc 10 g))
x (car xyz)
y (cadr xyz)
)
(if (equal (strcase typ) "TEXT")
(setq z (atof (cdr (assoc 1 g))))
(setq z (caddr xyz))
)
(setq dxfvl (list x y z))
(setq vl (append
vl
(list dxfvl)
)
)
)
)
(setq vl nil)
)
(setq vl vl)
)
(defun tfapf (fna str)
(setq fn (open fna "a"))
(princ str fn)
(close fn)
)
(defun c:zz (/ pa pb a b pc ab ac c)
(setq pa (getpoint "Specify first point:")
pb (getpoint "Specify second point:")
a (getreal "Specify first High:")
b (getreal "Specify second High:")
)
(while (setq pc (getpoint "Specify start point:")
ab (distance (list (car pa) (cadr pa))
(list (car pb)
(cadr pb)
)
)
ac (distance (list (car pa) (cadr pa))
(list (car pc)
(cadr pc)
)
)
c (+ a (* ac (/ (- b a) ab)))
)
(setq e (list (cons 0 "TEXT")
(cons 1 (rtos c 2 2))
(cons 8 "YGC")
(cons 10 pc)
(cons 40 1.0)
(cons 62 1)
)
)
(entmake e)
)
)
(defun tftext (tf_la hh cc / pc c e)
(setq pc (getpoint)
c (getreal)
)
(setq e (list (cons 0 "TEXT")
(cons 1 (rtos c 2 2))
(cons 8 tf_la)
(cons 10 pc)
(cons 40 hh)
(cons 62 cc)
)
)
(entmake e)
)
(defun c:xx () (tftext "sdg" 1.0 1))
(defun c:ss () (tftext "sjg" 1.5 6))
(defun c:bb (/ a b pa pb ab c e)
(setq a (getreal "高程:")
b (getreal "请输入比例系数:")
pa (getpoint "起点:")
)
(while (setq pb (getpoint "到下一个点文本位置:")
ab (distance (list (car pa) (cadr pa))
(list (car pb)
(cadr pb)
)
)
c (+ a (* ab b))
)
(setq e (list (cons 0 "TEXT")
(cons 1 (rtos c 2 2))
(cons 8 "YGC")
(cons 10 pb)
(cons 40 8.0)
(cons 62 1)
)
)
(entmake e)
)
)
(defun c:sdg (/ i lts typ i p0 d str sd sj e px py pe z lts)
(setvar "dimzin" 3)
(SETQ TYP "TEXT")
(prompt "起点距离")
(setq i (getdist))
(prompt "剖面线起点:")
(while (setq p0 (getpoint))
(setq d (strcat "0+" (rtos i 2 2) "\n"))
(tfapf "d:/sdg.txt" d)
(tfapf "d:/sjg.txt" d)
(setq str (ssget '((0 . "TEXT"))))
(setq sd (ssget "p" '((8 . "sdg"))))
(command "select" str "")
(setq sj (ssget "p" '((8 . "sjg"))))
(command "chprop" str "" "c" 2 "")
(foreach e (tfxyz sd)
(setq px (car p0)
py (cadr p0)
p0 (list px py)
)
(setq pe (list (car e) (cadr e)))
(setq d (distance p0 pe))
(setq d (rtos d 2 2))
(setq z (rtos (caddr e) 2 2))
(tfapf "d:/sdg.txt" d)
(tfapf "d:/sdg.txt" " ")
(tfapf "d:/sdg.txt" z)
(tfapf "d:/sdg.txt" "\n")
)
(foreach e (tfxyz sj)
(setq px (car p0)
py (cadr p0)
p0 (list px py)
)
(setq pe (list (car e) (cadr e)))
(setq d (distance p0 pe))
(setq d (rtos d 2 2))
(setq z (rtos (caddr e) 2 2))
(tfapf "d:/sjg.txt" d)
(tfapf "d:/sjg.txt" " ")
(tfapf "d:/sjg.txt" z)
(tfapf "d:/sjg.txt" "\n")
)
(prompt "请量取到下一根剖面线的距离")
(setq lts (getdist))
(setq i (+ lts i))
(prompt "剖面线起点:")
)
) | 
发表于 2007-3-31 19:04
置顶卡
变色卡
显身卡