有个LISP程序请教！很急很急！！！！！！！

叶文军 发表于 2004-6-2 19:34:00

下面这个程序是小弟修改过的，有个问题不懂：当输入的比例尺为1：200时，“建筑占地面积”一栏显示的位置是正确的，但是为其它时，该栏的位置会因比例尺的大小而垂直移动，想请哪位老大帮忙改一下，谢谢！另外一个问题：该程序只能量算并标注直线的长度，却不能量算弧形的长度，而且不能显示中文字体（在CAD2002中），很令我头疼。还有一个图层的问题：该程序必须要有CASS中的几个图层才能用，单独一个0层就不能用了，可以帮忙改一下吗？谢谢，我很急啊！小弟的EMAIL：ywj_82@163.com

(defun c:zdt8 () (setq s (getint "\n 请输入比例尺(1:200)1:")) (if (> 100 s) (progn (setq ss (/ 200 100)) (setq sbl 200) (terpri) ;(setq ssbl (rtos sbl 2 1)) ;(princ ssbl )(terpri) ) (progn (setq ss (/ s 100)) (setq sbl s) ;(setq ssbl (rtos sbl 2 1)) ;(princ ssbl )(terpri) ) ) (setq ss1 (rtos (* ss 0.03) 2 2)) (setq ss2 (rtos (* ss 0.05) 2 2)) (setq ss3 (rtos (* ss 0.2) 2 2)) ;(princ ss1 )(terpri) 　 ;(princ "\n please select one ployline or many ploylines") (setq lun (getvar "lunits")) (princ lun) (terpri) ;(princ "\n") (setq lup (getvar "luprec")) (princ lup) (terpri) (setq lay (getvar "clayer")) (princ lup) (terpri) (setvar "lunits" 2) (setvar "luprec" 8) (setq ent (ssget)) (setq l (sslength ent)) (setq ll (1- l)) (setvar "cmdecho" 0) (while (> ll -1) (setq e (ssname ent ll)) (command "area" "e" e) (setq arr (getvar "area")) (setq arr1 (rtos arr 2 2)) (command "layer" "s" "jzd" "") (command "pedit" e "w" ss1 "") ;(command "pedit" e "w" 0 "") (command "change" e "" "p" "la" "jzd" "c" "bylayer" "") (setvar "clayer" lay) ;(command "text" aa "1.5" "0" arr1 ) ;(princ arr1) (terpri) ;(setq ar0 (vl-list* ar)) ;(princ ar0 ) (setq ar (entget e)) ;(setq ar0 (vl-list* ar)) ;(princ ar0 ) (setq pt0 (cdr (assoc '10 ar))) (setq pt1 (cdr (assoc '10 ar))) (setq sumx 0 sumy 0 ) (setq sum 0) (setq x3 (car pt0) y3 (cadr pt0) ) (setq x4 (car pt0) y4 (cadr pt0) ) ;(setq zbb (getint "\n 是否画界址点坐标表：1、画， 2、否")) ;(if (= 1 zbb) ;(progn ;(setq jzb (getpoint "\n please input the up-left point")) ;(setq jzbx (car jzb) jzby (cadr jzb)) ;(setq jzdx (rtos jzdx 2 2) jzdy (rtos jzdy 2 2)) ;(command "text" "j" "m" jzdx "1.5" "0" (list jzdx jzdy) "") ;);progn ;) (setq pt2 (cdr (assoc '10 ar))) (setq jzdh 2) (setq num 1) (while (= 1 num) ;( repeat 4 ;(princ pt2)(terpri) (setq pt1 (cdr (assoc '10 ar))) (setq x1 (car pt1) y1 (cadr pt1) ) (setq y3 (max y3 y1) y4 (min y4 y1) ) (setq x3 (max x3 x1) x4 (min x4 x1) ) (setq aa (list (/ (+ x3 x4) 2) (/ (+ y3 y4) 2))) (setq sum (1+ sum)) (setq x (car pt1) y (cadr pt1) ) ;(command "text" "j" "ml" pt1 ss3 "0" jzdh "") ;(setq jzdh ( 1+ jzdh)) (setq sumx (+ sumx x) sumy (+ y sumy) ) ;(setq x3 (/ sumx sum) y3 (/ sumy sum)) (command "layer" "s" "jzd" "") (command "circle" pt1 ss2 "") (setvar "clayer" lay) (setq old (assoc '10 ar)) (setq ar (subst '(20) old AR)) ;(setq pt2 ( cdr (assoc '10 ar))) ;(princ pt2)(terpri) ;(princ "\n the program error!") (if (/= nil (assoc '10 ar)) (progn ;(cond ( /= nil (assoc '10 ar )) (setq num 1) (setq pt2 (cdr (assoc '10 ar))) (princ pt2) (terpri) (setq jl (distance pt1 pt2)) (setq a (rtos jl 2 2)) (setq b1 (angle pt1 pt2)) (setq ang0 (+ 90 b1)) (setq dist (* 0.2 ss)) (setq x1 (car pt1) y1 (cadr pt1) ) (setq x2 (car pt2) y2 (cadr pt2) ) ;(setq sum ( 1+ sum)) ;(setq sumx ( + sum x1 ) sumy (+ y1 sumy)) ;(setq y3 (max y3 y1) y4 (min y4 y1)) ;(setq aa (list ( / ( + x3 x4) 2 ) ( / ( + y3 y4 ) 2))) ;(princ aa)(terpri) (setq x5 (/ (+ x1 x2) 2)) (setq y5 (/ (+ y1 y2) 2)) (setq pt5 (list x5 y5)) (if (< x1 x2) (if (< y2 y1) (if (< -1 (/ (- y2 y1) (- x2 x1))) (setq b1 (+ pi b1))

) ) ) (if (< x2 x1) (if (> y2 y1) (if (< -1 (/ (- y2 y1) (- x2 x1))) (setq b1 (+ pi b1)) ) (setq b1 (+ pi b1)) ) (if (< y2 y1) (setq b1 (+ pi b1)) ) ) (setq pt (polar pt5 ang0 dist)) (setq b2 (* (/ b1 Pi) 180)) (setq ptjzdh (polar pt2 ang0 dist)) (command "layer" "s" "zj" "") (command "text" "j" "m" ptjzdh ss3 "0" jzdh "") (setq jzdh (1+ jzdh)) (command "text" "j" "mc" pt ss3 b2 a) (setvar "clayer" lay) ) ;progn (progn (setq num -1) ;(princ num)(terpri) ;(princ pt0) (setq jl (distance pt1 pt0)) ;(princ s) (setq a (rtos jl 2 2)) (setq b1 (angle pt1 pt0)) (setq ang0 (+ 90 b1)) (setq dist (* 0.2 ss)) (setq x1 (car pt1) y1 (cadr pt1) ) (setq x2 (car pt0) y2 (cadr pt0) ) (setq x5 (/ (+ x1 x2) 2)) (setq y5 (/ (+ y1 y2) 2)) (setq pt5 (list x5 y5)) (if (< x1 x2) (if (< y2 y1) (if (< -1 (/ (- y2 y1) (- x2 x1))) (setq b1 (+ pi b1))

) ) ) (if (< x2 x1) (if (> y2 y1) (if (< -1 (/ (- y2 y1) (- x2 x1))) (setq b1 (+ pi b1)) ) (setq b1 (+ pi b1)) ) (if (< y2 y1) (setq b1 (+ pi b1)) ) ) (setq pt (polar pt5 ang0 dist)) (setq b2 (* (/ b1 Pi) 180)) (setq ptjzdh (polar pt0 ang0 dist)) (command "layer" "s" "zj" "") (command "text" "j" "m" ptjzdh ss3 "0" "1" "") ;(command "layer" "s" "zj" "") (command "text" "j" "mc" pt ss3 b2 a) (setvar "clayer" lay) ; (SETQ AA (GETPOINT "面积注记位置:")) ;(command "layer" "s" "jzd" "") ; (command "text" "j" "m" aa "1.5" "0" arr1 "") ) ;progn ) ;if ;(setq p (list x1 y1 )) ;(command "text" "j" "m" p "1.0" "0" dh) ;(setq dh ( 1 + dh)) ;) ) ;while 1 ;(command"change" e "" "p" "la" "zj" "c" "bylayer" "") ;(command"change" e "" "" "" "" "1.5" "" "" "") ;(SETQ AA (GETPOINT "面积注记位置:")) ;(command "layer" "s" "jzd" "") ;(setq x3 (/ sumx sum) y3 (/ sumy sum)) ;(setq aa (list x3 y3 )) (setq xcen (/ (+ x3 x4) 2) ycen (/ (+ y3 y4) 2) ) (setq aa (list xcen ycen)) (command "layer" "s" "jzd" "") ;;;;;(SETQ AA (GETPOINT "面积注记位置:")) ;(setq zdh (getstring "输入宗地号：")) (command "text" "j" "ml" aa ss3 "0" arr1) (setq aa0 (list (- xcen (* 0.4 ss)) ycen)) (command "line" aa0 aa "") (setq zdh (getstring "输入宗地号：")) (setq aa (list (- xcen (* 0.2 ss)) (+ (* 0.16 ss) ycen))) (command "text" "j" "mc" aa ss3 "0" zdh) (setq ydlb (getstring "输入用地类别：")) (setq aa (list (- xcen (* 0.2 ss)) (- ycen (* 0.16 ss)))) (command "text" "j" "mc" aa ss3 "0" ydlb) (setvar "clayer" lay) ;;;(setq blc0 (getreal "请输入宗地图比例尺1:")) ;;; ;(setq sbl0 (rtos s 2 2)) ;(princ sbl0)(terpri) ;(setq ssbl (rtos sbl 2 1)) ;(princ "sbl:") ;(princ sbl )(terpri) ;(princ "blc0:") ;;;加宗地图框及文字---- (setq blc (/ sbl 1000.0)) (setq aa (list xcen ycen)) (setq xaa (- (car aa) (* 160 blc))) (setq yaa (- (cadr aa) (* 96 blc))) (setq aa (list xaa yaa)) (setq zlpt (list (+ xaa (* 14.5 blc)) (+ yaa (* 196.5 blc)))) (princ zlpt) (terpri) (setq mcpt (list (+ xaa (* 144.0 blc)) (+ yaa (* 196.5 blc)))) (setq thpt (list (+ xaa (* 258.0 blc)) (+ yaa (* 196.5 blc)))) (setq dhpt (list (+ xaa (* 305.0 blc)) (+ yaa (* 196.5 blc)))) (setq blcpt (list (+ xaa (* 160 blc)) (+ yaa (* -5.0 blc)))) (setq wyrmpt (list (+ xaa (* 18.40 blc)) (+ yaa (* -7.10 blc)))) (setq newyrmpt (list (+ xaa (* 93.10 blc)) (+ yaa (* -7.10 blc)))) (setq fhrmpt (list (+ xaa (* 93.10 blc)) (+ yaa (* -13.70 blc)))) (setq wyyearpt (list (+ xaa (* 35.90 blc)) (+ yaa (* -7.0 blc)))) (setq wyyuept (list (+ xaa (* 49.60 blc)) (+ yaa (* -7.0 blc)))) (setq wydaypt (list (+ xaa (* 61.20 blc)) (+ yaa (* -7.0 blc)))) (setq newyearpt (list (+ xaa (* 110.60 blc)) (+ yaa (* -7.0 blc)))) (setq newyuept (list (+ xaa (* 124.3 blc)) (+ yaa (* -7.0 blc)))) (setq newdaypt (list (+ xaa (* 135.9 blc)) (+ yaa (* -7.0 blc)))) (setq jhyearpt (list (+ xaa (* 35.90 blc)) (+ yaa (* -15 blc)))) (setq jhyuept (list (+ xaa (* 49.60 blc)) (+ yaa (* -15 blc)))) (setq jhdaypt (list (+ xaa (* 61.20 blc)) (+ yaa (* -15 blc)))) (setq fhyearpt (list (+ xaa (* 110.60 blc)) (+ yaa (* -15 blc)))) (setq fhyuept (list (+ xaa (* 124.30 blc)) (+ yaa (* -15 blc)))) (setq fhdaypt (list (+ xaa (* 135.90 blc)) (+ yaa (* -15 blc)))) (setq jhrmpt (list (+ xaa (* 18.4 blc)) (+ yaa (* -13.70 blc)))) ;(setq jhrmpt (list 29.40 -13.6)) (SETQ zlss (GETstring "请输入座落:")) ;(setq zz (rtos (* 4 blc0) 2 2)) ;(princ) (setq zlzd (rtos (* 4 blc) 2 1)) (princ zlzd) (command "text" zlpt (rtos (* 4 blc) 2 2) "0" zlss) (SETQ mcss (GETstring "请输入单位名称:")) (command "text" mcpt (rtos (* 4 blc) 2 2) "0" mcss) (SETQ thss (GETstring "请输入分幅图号:")) (command "text" "j" "c" thpt (rtos (* 4 blc) 2 2) "0" thss) ;(SETQ dhss (GETstring "请输入地号:")) (command "text" "j" "c" dhpt (rtos (* 4 blc) 2 2) "0" zdh) ;(SETQ blss (GETstring "请输入比例尺:")) (setq s (rtos sbl 2 0)) (setq blcss (strcat "1:" s)) (command "text" "j" "c" blcpt (rtos (* 4 blc) 2 2) "0" blcss ) (COMMAND "INSERT" "8kh" AA (rtos blc 2 2) (rtos blc 2 2) "") (setq tkzdmjpt (list (+ xaa (* 265.00 blc)) (+ yaa (* 27.7 blc)))) ;(setq tkzdmjpt (list 250.00 27.70)) (setq tkzdmj0 (strcat "宗地面积:" arr1 "m")) ;(setq tkzdmj (strcat tkzdmj0 arr1)) ;(princ tkzdmj) (command "text" tkzdmjpt (rtos (* 3 blc) 2 2) "0" tkzdmj0) (setq tkjzzdmjpt (list (+ xaa (* 265.00 blc)) (+ yaa (* (- 9.46 6.2) blc)) ) ;(setq tkjzzdmjpt (list 250.00 27.70)) (setq tkjzzdmj0 (strcat "建筑占地面积:" arr1 "m")) ;(setq tkjzzdmj (strcat tkjzzdmj0 arr1)) ;(princ tkjzzdmj) (command "text" tkjzzdmjpt (rtos (* 3 blc) 2 2) "0" tkjzzdmj0 ) (setq tkjzmjpt (list (+ xaa (* 265.00 blc)) (+ yaa (* (- 27.7 6.2) blc)) )) ;(setq tkzdmj (strcat dhss "建筑面积:" arr1)) (setq jzAR (atof arr1)) ;(setq jgcc (getint "\n please input house's floors:")) ;(if (> 1 jgcc) (setq tkjzAR (rtos jzAR 2 2)) ; (setq tkjzAR (rtos (* jzAR jgcc) 2 2)) ;)

;(command "text" tkjzmjpt ( rtos (* 3 blc) 2 2) "0" tkjzAR) (setq tkftxspt (list (+ xaa (* 265.00 blc)) (+ yaa (* (- 15.30 6.20) blc)) ) ) (setq jgcc (getint "\n 1.砖、2.砖2、3.砖3、4.砖4、5.砖5、6.砖6、7.砖7、8.厕、9.木、0.木2:" ) ) (if (> 1 jgcc) (setq ssjgcc 1) (setq ssjgcc jgcc) ) (setq tkjzAR (rtos (* jzAR ssjgcc) 2 2)) (setq tkjzAR0 (strcat "建筑面积:" tkjzAR "m")) ;(setq tkjzAR (rtos jzAR 2 2)) ;(defun c:zz() ;(vmon) ;(SETQ SS 1) ;(setq s (getint"\n Please input number(1:500)1:" ) ) ;(if (> 100 s) ;(setq ss1 (* 0.3 (/ 500 100))) ;(setq ss1 (* (/ s 100) 0.3))) ;(setq ss2 (* ss1 0.8)) ;(princ "\n 1.砖、2.砖2、3.砖3、4.砖4、5.砖5、6.砖6、7.砖7、8.厕、9.木、0.木2:") (setq ss1 (* 3 (/ sbl 1000.00))) (setq ss2 (* ss1 0.8)) (setq jgccaa (list xcen (- ycen (* 6 blc)))) ;(setq ssjgcc (getint "\n choose the number(0-9): ")) ; (cond ((= ssjgcc 1) (setq m "砖") ; (command "layer" "M" "zj" "") ; (command "text" jgccaa ss1 "0" m )) ; ((= ssjgcc 2) (setq m "砖") ; (command "layer" "M" "zj" "") ; (command "text" jgccaa ss1 "0" m ) ; (setq jgccp1 (polar jgccaa 0.1 ss1)) ; (command "text" jgccp1 ss2 "0" "2")) ; ((= ssjgcc 3) (setq m "砖") ; (command "layer" "M" "zj" "") ; (command "text" jgccaa ss1 "0" m ) ; (setq jgccp1 (polar jgccaa 0.1 ss1)) ; (command "text" jgccp1 ss2 "0" "3")) ; ((= ssjgcc 4) (setq m "砖") ; (command "layer" "M" "zj" "") ; (command "text" jgccaa ss1 "0" m ) ; (setq jgccp1 (polar jgccaa 0.1 ss1)) ; (command "text" jgccp1 ss2 "0" "4")) ; ((= ssjgcc 5) (setq m "砖") ; (command "layer" "M" "zj" "") ; (command "text" jgccaa ss1 "0" m ) ; (setq jgccp1 (polar jgccaa 0.1 ss1)) ; (command "text" jgccp1 ss2 "0" "5")) ; ((= ssjgcc 6) (setq m "砖") ; (command "layer" "M" "zj" "") ; (command "text" jgccaa ss1 "0" m ) ; (setq jgccp1 (polar jgccaa 0.1 ss1)) ; (command "text" jgccp1 ss2 "0" "6")) ; ((= ssjgcc 7) (setq m "砖") ; (command "layer" "M" "zj" "") ; (command "text" jgccaa ss1 "0" m ) ; (setq jgccp1 (polar jgccaa 0.1 ss1)) ; (command "text" jgccp1 ss2 "0" "7")) ; ((= ssjgcc 8) (setq m "厕") ; (command "layer" "M" "zj" "") ; (command "text" jgccaa ss1 "0" m ) ; (setq p1 (polar jgccaa 0.1 ss1)) ; (command "text" jgccp1 ss2 "0" "")) ; ((= ssjgcc 9) (setq m "木") ; (command "layer" "M" "zj" "") ; (command "text" jgccaa ss1 "0" m )) ; ((= ssjgcc 0) (setq m "木") ; (command "layer" "M" "zj" "") ; (command "text" jgccaa ss1 "0" m ) ; (setq jgccp1 (polar jgccaa 0.1 ss1)) ; (command "text" jgccp1 ss2 "0" "2")) ; )

(setq wyrmint (getint "\n 外业: 1、叶文军 2、朱林威 3、金义阳 4、谢国胜" ) ) (if (> 1 wyrmint) (setq wyrm 1) (setq wyrm wyrmint) ) (cond ((= wyrm 1) (setq m "叶文军")) ((= wyrm 2) (setq m "朱林威")) ((= wyrm 3) (setq m "金义阳")) ((= wyrm 4) (setq m "谢国胜"))

)

(setq newyrmint (getint "\n 内业: 1、叶文军 2、朱林威 3、金义阳 4、谢国胜" ) ) (if (> 1 newyrmint) (setq newyrm 1) (setq newyrm wyrmint) ) (cond ((= newyrm 1) (setq m "叶文军")) ((= newyrm 2) (setq m "朱林威")) ((= newyrm 3) (setq m "金义阳")) ((= newyrm 4) (setq m "谢国胜"))

) (command "text" "j" "c" wyrmpt (rtos (* 5 blc) 2 2) "0" m) (command "text" "j" "c" newyrmpt (rtos (* 5 blc) 2 2) "0" m) (command "text" "j" "c" jhrmpt (rtos (* 5 blc) 2 2) "0" "金晓军" ) (command "text" "j" "c" fhrmpt (rtos (* 5 blc) 2 2) "0" "杨昌林" ) (command "text" tkjzmjpt (rtos (* 3 blc) 2 2) "0" tkjzAR0) (setq ftAR (atof arr1)) (setq jzAR (atof tkjzAR)) (setq ftxs0 (/ ftAR jzAR)) (setq ftxs (rtos ftxs0 2 8)) (setq ftxs (strcat "各户分摊系数:" ftxs)) ;(princ wyyear)(terpri) ;;;2000年1月1日为2451549 ;;;2001年1月1日为2451915 ;;;2002年1月1日为2452280 ;;;2003年1月1日为2452645 ;;;2004年1月1日为2453010 ;;;2005年1月1日为2453376 ;;;2006年1月1日为2453741 ;;;2007年1月1日为2454106 ;;;2012年12月30日前用! ;(DEFUN C:Date() ;(setvar "luprec" 8) ;(setvar "lunits" 2) (setq nowdate (getvar "date")) (princ nowdate) (terpri) (setq january 31) (setq february 28) (setq march 31) (setq april 30) (setq may 31) (setq june 30) (setq july 31) (setq augual 31) (setq september 30) (setq october 31) (setq november 30) (setq december 31) (if (> 2451911 nowdate) (progn (setq wyyear 2000) (setq newyear 2000) (setq olddate 2451879) (setq subdays (- (fix nowdate) olddate)) (princ subdays) (terpri) (setq newyue 12) (setq wyyue newyue) (princ newyue) (terpri) (setq newday subdays) (princ newday) (terpri) (setq wyday (- newday 7)) (princ newday) (terpri) (princ wyday) (terpri) ) (progn (setq olddate 2451910) (setq subdays (fix (- nowdate olddate))) (princ subdays) (terpri) (setq wyyear (+ 2001 (fix (/ (- subdays 1) 365)))) (setq newyear (+ 2001 (fix (/ (- subdays 1) 365)))) (princ newyear) (terpri) (setq subdays (- subdays (* (fix (/ (- subdays 1) 365)) 365))) (princ subdays) (terpri)

(if (and (= subdays 1) (>= newyear 2005) (<= newyear 2008)) (progn (setq subdays 366) (setq wyyear (- newyear 1)) (setq newyear (- newyear 1)) ) ) (if (and (> subdays 1) (>= newyear 2005) (<= newyear 2008)) (setq subdays (- subdays 1)) ) (if (and (= subdays 1) (>= newyear 2009) (<= newyear 20012)) (progn (setq subdays 366) (setq wyyear (- newyear 1)) (setq newyear (- newyear 1)) ) ) (if (and (= subdays 2) (>= newyear 2009) (<= newyear 20012)) (progn (setq subdays 367) (setq wyyear (- newyear 1)) (setq newyear (- newyear 1)) ) ) (if (and (> subdays 2) (>= newyear 2009)) (setq subdays (- subdays 2)) ) (if (or (= newyear 2004) (= newyear 2008) (= newyear 2012)) (setq february 29) ) (if (> (+ 1 january february march april may june) subdays) (progn (if (> (+ 1 january february march) subdays) (progn (if (> (+ 1 january) subdays) (progn (setq newyue 1) (princ "january 31") (terpri) (setq newday subdays) (if (> 8 subdays) (progn (setq wyyue 12) (setq wyday (+ 24 newday)) (setq wyyear (- wyyear 1)) ) (progn (setq wyyue 1) (setq wyday (- newday 7)) ) ) ) )

(if (and (< (+ january) subdays) (> (+ 1 january february) subdays) ) (progn (setq newyue 2) (princ newyue) (terpri) (setq newday (- subdays january)) (princ newday) (terpri) (if (> 8 newday) (progn (setq wyyue 1) (princ wyyue) (terpri) (setq wyday (+ (- january 7) newday)) (princ wyday) (terpri) ) (progn (setq wyyue newyue) (setq wyday (- newday 7)) ) ) ) )

(if (< (+ january february) subdays) (progn ;(princ february)(terpri) (setq newyue 3) (setq newday (- subdays (+ january february))) (if (> 8 newday) (progn (setq wyyue 2) (setq wyday (+ (- february 7) newday)) ) (progn (setq wyyue newyue) (setq wyday (- newday 7)) ) ) ) ) ) ;progn ) ;if (if (and (< (+ january february march) subdays) (> (+ 1 january february march april may june) subdays) ) (progn (if (> (+ 1 january february march april) subdays) (progn ;(princ february)(terpri) (setq newyue 4) (setq newday (- subdays (+ january february march))) (if (> 8 newday) (progn (setq wyyue 3) (setq wyday (+ 24 newday)) ) (progn (setq wyyue newyue) (setq wyday (- newday 7)) ) ) ) ) (if (and (< (+ january february march april) subdays) (> (+ 1 january february march april may) subdays) ) (progn ;(princ "february") ;(princ february)(terpri) (setq newyue 5) (setq newday (- subdays (+ january february march april) ) ) (if (> 8 newday) (progn (setq wyyue 4) (setq wyday (+ 23 newday)) ) (progn (setq wyyue newyue) (setq wyday (- newday 7)) ) ) ) ) (if (< (+ january february march april may) subdays) (progn ;(princ february)(terpri) (setq newyue 6) (setq newday (- subdays (+ january february march april may) ) ) (if (> 8 newday) (progn (setq wyyue 5) (setq wyday (+ 24 newday)) ) (progn (setq wyyue newyue) (setq wyday (- newday 7)) ) ) ) ) ) ) ) ) (setq sum16 (+ january february march april may june)) (princ sum16) (terpri) (if (< (+ january february march april may june) subdays) (progn (if (> (+ 1 sum16 july augual september) subdays) (progn (if (> (+ 1 sum16 july) subdays) (progn (setq newyue 7) ;(princ "january 31")(terpri) (setq newday (- subdays sum16)) (if (> 8 newday) (progn (setq wyyue 6) (setq wyday (+ 23 newday)) ;(setq wyyear (- wyyear 1)) ) (progn (setq wyyue newyue) (setq wyday (- newday 7)) ) ) ) )

(if (and (< (+ sum16 july) subdays) (> (+ 1 sum16 july augual) subdays) ) (progn (setq newyue 8) (princ newyue) (terpri) (setq newday (- subdays (+ sum16 july))) (princ newday) (terpri) (if (> 8 newday) (progn (setq wyyue 7) (princ wyyue) (terpri) (setq wyday (+ (- july 7) newday)) (princ wyday) (terpri) ) (progn (setq wyyue newyue) (setq wyday (- newday 7)) ) ) ) )

(if (< (+ sum16 july augual) subdays) (progn ;(princ february)(terpri) (setq newyue 9) (setq newday (- subdays (+ sum16 july augual))) (if (> 8 newday) (progn (setq wyyue 8) (setq wyday (+ (- augual 7) newday)) ) (progn (setq wyyue newyue) (setq wyday (- newday 7)) ) ) ) ) ) ;progn ) ;if (setq sum79 (+ july augual september)) (setq sum19 (+ sum16 sum79)) (if (< sum19 subdays) (progn (if (> (+ 1 sum19 october) subdays) (progn ;(princ february)(terpri) (setq newyue 10) (setq newday (- subdays sum19)) (if (> 8 newday) (progn (setq wyyue 9) (setq wyday (+ 23 newday)) ) (progn (setq wyyue newyue) (setq wyday (- newday 7)) ) ) ) ) (if (and (< (+ sum19 october) subdays) (> (+ 1 sum19 october november) subdays) ) (progn (setq newyue 11) (setq newday (- subdays (+ sum19 october))) (if (> 8 newday) (progn (setq wyyue 10) (setq wyday (+ 24 newday)) ) (progn (setq wyyue newyue) (setq wyday (- newday 7)) ) ) ) ) (if (< (+ sum19 october november) subdays) (progn ;(princ february)(terpri) (setq newyue 12) (setq newday (- subdays (+ sum19 october november))) (if (> 8 newday) (progn (setq wyyue 11) (setq wyday (+ 23 newday)) ) (progn (setq wyyue newyue) (setq wyday (- newday 7)) ) ) ) ) ) ) ) ) ) ;progn ) ;if (command "text" "j" "c" wyyearpt (rtos (* 3.3 blc) 2 2) "0" wyyear ) (command "text" "j" "c" wyyuept (rtos (* 3.3 blc) 2 2) "0" wyyue ) (command "text" "j" "c" wydaypt (rtos (* 3.3 blc) 2 2) "0" wyday ) (command "text" "j" "c" newyearpt (rtos (* 3.3 blc) 2 2) "0" newyear ) (command "text" "j" "c" newyuept (rtos (* 3.3 blc) 2 2) "0" newyue ) (command "text" "j" "c" newdaypt (rtos (* 3.3 blc) 2 2) "0" newday ) (command "text" "j" "c" jhyearpt (rtos (* 3.3 blc) 2 2) "0" newyear ) (command "text" "j" "c" jhyuept (rtos (* 3.3 blc) 2 2) "0" newyue ) (command "text" "j" "c" jhdaypt (rtos (* 3.3 blc) 2 2) "0" newday ) (command "text" "j" "c" fhyearpt (rtos (* 3.3 blc) 2 2) "0" newyear ) (command "text" "j" "c" fhyuept (rtos (* 3.3 blc) 2 2) "0" newyue ) (command "text" "j" "c" fhdaypt (rtos (* 3.3 blc) 2 2) "0" newday ) (command "text" tkftxspt (rtos (* 3 blc) 2 2) "0" ftxs) (princ newyear) (terpri) (setvar "clayer" lay) (setq ll (1- ll)) ) (setvar "cmdecho" 1) (setvar "lunits" lun) (setvar "luprec" lup) (setvar "clayer" lay) )

meflying 发表于 2004-6-2 20:16:00

如果你对程序不怎么懂，建议你不要去修改。。。

如果你想使用，可以有两个方法，

1、说出你的要求，看能不能让别人帮你写一个。。。

2、给出原来程序（必须是正确能用的），然后说说你在功能上需要哪些改动。。。

这样一个经你修改却又有错的程序，找出错误并满足你的需求是很困难的

叶文军 发表于 2004-6-2 20:56:00

可以在这个程序的基础上修改一下吗？要求如下：

1、比例尺，座落，使用人（单位）姓名，图号，地号，宗地面积，建筑面积，建筑占面积，各户分摊系数（建筑面积除以宗地面积），外业（wyrmint),内业（newyrmint），还有时间这些数据都必须要，而且位置就和上面的一个样。

2、我用PL线圈出一个闭合的图形，输入一个zdt8的命令，提示输入比例尺，再提示选择图形，用户点一所需图形，系统自动对其边线的长度进行量算并标注在线中心位置（不要标在线上），并在每个转点画上一个圆（直径为1.5mm）并标上序号（1，2。。。。。），在图形中间注上图形面积。

可以做到吗？谢谢，你让我看到了希望，原来的程序也出错了，我只是在中间加了一个“建筑占地面积”“内业”两项，其它一点没动。谢谢老大

前生发表于 2004-6-2 21:02:00

程序太长，有写晕。

好想陈伯兄老师关于PLine线的一个例子在网上到处都有啊。

叶文军 发表于 2004-6-2 21:09:00

实际上一点都不长的啦,时间一项不用改,宗地面积不用改,座落、使用者、图号、地号都不用改，还有外业一项也可以不用改，唯一要改的就是建筑占地面积，弧线长度标注，内业这三项要帮忙改一下，其它的都可以正常运行的。可以帮一下忙吗？谢谢了，我到现在一直在等。。。。。。。。

前生发表于 2004-6-2 21:15:00

呵呵，你很幸福啊。

在网上，不用下来。

.你的程序。可以开很多地方。想什么text 的什么。可以写个小的子函数啊/

程序还是太长，没有心思看。

呵呵

meflying 发表于 2004-6-2 21:48:00

叶文军发表于2004-6-2 20:56:00static/image/common/back.gif可以在这个程序的基础上修改一下吗？要求如下：

1、比例尺，座落，使用人（单位）姓名，图号，地号，宗地面积，建筑面积，建筑占面积，各户分摊系数（建筑面积...

 你说这个程序是你修改过的，我想最好在原程序上改。。。你这个程序哪儿来的？怎么会是一个错误的程序，既然这样你就不应该用它啊。。。

我看你的要求很模糊啊，不知道是要改还是要新写。。。看1，列出那么多东西，不知道做什么，怎么做，好象是改。。。看2，又像是提出了要求，要写。。。希望明确点——注意，由于程序太长，所以不可能去读完了，而且你又说有错的，也无法运行，所以我对这个程序做什么的是一点都不知道的，你说问题的时候应该考虑到这点，不要认为我对这个程序做的事情已经比较清楚了

图可以在这里帖上来的，发帖时输入内容的上方有个上传文件，只要上传图形文件就可以了

alin 发表于 2004-6-2 23:12:00

根本不考虑别人的难处。程序中有很多(command "layer" "s" ...)的语句，图中没有该图层就会出错，所以一定要上传图形文件。还有，后部有一大段好像在计算日期啥的，要那么复杂吗？没看懂，因为根本不能运行。

叶文军 发表于 2004-6-3 09:53:00

上面的图就是我希望达到的,请各位多多帮小弟一把,谢谢!

meflying 发表于 2004-6-3 10:36:00

还有几个问题：

对于个文字、图形的图层、字体、文字类型、颜色有些什么要求？是否就按图中来，还是不需要考虑

图框大小是否变化，是不是在程序中插入块？块是否需要打散？你块中已有一些姓名，新输入的如何写？

宗地面积是否就是占地面积？

界址点号第一点怎么确定？

还有，用在什么版本的CAD？

页: [1] 2 3

明经CAD社区's Archiver

有个LISP程序请教！很急很急！！！！！！！