[LISP程序]：我的几个关于文字的Lisp程序。

zhuquanmao

;;钢筋表计算程序，版本：4.12。
;;输入直径、单根长、根数。钢筋直径可用"%%c32、%%13132、f32"等形式，长度及根数可输入简单四则运算
;;符号，如"30*(22+3)、30x3X4"形式，可用"X"或"x"代替"*"，但不可用中文符号。
;;命令：ＣＡ -- 计算钢筋表。
;;命令：ＤＴＷ -- 由直径计算单位重。
;;命令：ＣＡＴ -- 计算钢筋总重。
;;命令：ＣＡＳ -- 统计钢筋长度或重量。
;;自由软件，欢迎复制、修改。作者：南京市市政设计研究院 嵇龙(ll_j@21cn.com)
;;                                                            025－3283626


(defun newerr(s)
  (if (= s "Function cancelled")
    (progn
      (setq *error* olderr)
      (if oldsnp (setvar "osmode" oldsnp))
      (if oldzin (setvar "dimzin" oldzin))
    )
  )
  (princ)
)

(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 "cm") (setq ca:c_m "mm" ca:cmm 0.001) (setq ca:c_m "cm" ca:cmm 0.01))
     (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 (atof (ca_f (cdr (assoc 1 e01)))) se1 se0)
    (if (not ca:r) (setq ca:r (assoc 50 e01)))
    (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(ca_trans 10 e01)) (caddr(ca_trans 10 e02))
                   (caddr(ca_trans 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 (trans pt1 1 0))
    (if (= ca:r_w 3) (ca_mktext n5 (trans pt2 1 0)))
    (ca_mktext n6 (trans pt3 1 0))
  )
)

(defun ca_prw(/ p_w)
  (setq pt (getpoint (strcat "\n合计钢筋总重" ca:jm "对齐点: ")))
  (if (/= pt nil)
    (ca_mktext (rtos n6_ 2 2) (trans pt 1 0))
    (progn
      (initget "Yes No")
      (setq p_w (getkword "\n取消合计总重？ Yes or <No>?"))
      (if (/= p_w "Yes")
        (ca_prw)
      )
    )
  )
)

(defun ca_trans(n ens)
  (cons n (trans (cdr (assoc n ens)) 0 1))
)

(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)))
  )
  (eval 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)
      ca:r
      (assoc 41 (tblsearch "style" sty))
      (cons 51 (cdr (assoc 50 (tblsearch "style" sty))))
      '(71 . 0)
      (cons 72 ca:j_m)
;      (cons 73 :j2)
    )
  )
)


(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 cas_main        ()
  (princ (strcat "\n\n输出行间距 " (rtos ca:l_ 2 1) "；列间距 " (rtos ca:h_ 2 1)
                 "; 文本字高 " (rtos ca:hh 2 2) "。\n"))
  (initget 1 "L C H")
  (setq        pt1 (getpoint (strcat "行间距L/列间距C/文本字高H/<给出输出基点>: ")))
  (cond
    ((= pt1 "L")
     (setq c (getdist (strcat "\n给定行间距< " (rtos ca:l_ 2 1) " >: ")))
     (if (/= c nil) (setq ca:l_ c))
     (cas_main)
    )
    ((= pt1 "C")
     (setq c (getdist (strcat "\n给定列间距< " (rtos ca:h_ 2 1) " >: ")))
     (if (/= c nil) (setq ca:h_ c))
     (cas_main)
    )
    ((= pt1 "H")
     (setq c (getdist (strcat "\n给定字高< " (rtos ca:hh 2 2) " >: ")))
     (if (/= c nil) (progn (setq ca:hh c) (setvar "textsize" c)))
     (cas_main)
    )
    (t
     (while (> l1 0)
       (ca_smax se1 l1)
       (setq e01 e20
             n1         (ca_f (cdr (assoc 1 e01)))
             se1 se0
       )
       (if (not ca:r)
         (setq ca:r (assoc 50 e01))
       )
       (ca_smax se2 l1)
       (setq e02 e20
             n2         (ca_n (cdr (assoc 1 e02)))
             se2 se0
       )
       (setq l1        (sslength se1)
             l0        (length cas:b)
             i        0
             ii        0
       )
       (if (> l0 0)
         (progn
           (repeat l0
             (setq b0 (nth i cas:b))
             (if (= (car b0) n1)
               (setq n2           (+ n2 (cadr b0))
                     cas:b (subst (list n1 n2) b0 cas:b)
                     i           (1+ i)
                     ii           1
               )
               (setq i (1+ i))
             )
           )
           (if (= ii 0)
             (setq cas:b (reverse (cons (list n1 n2) (reverse cas:b))))
           )
         )
         (setq cas:b (cons (list n1 n2) cas:b))
       )
     )
     (setq l0        (length cas:b)
           i        0
           pt1x        (car pt1)
           pt1y        (cadr pt1)
           pt2x        (+ pt1x ca:h_)
     )
     (repeat l0
       (setq pt1  (list pt1x (- pt1y (* i ca:l_)) 0)
             pt2  (list pt2x (- pt1y (* i ca:l_)) 0)
             n1   (- (apply 'min (mapcar 'atof (mapcar 'car cas:b))) 1)
             n2   (apply 'max (mapcar 'atof (mapcar 'car cas:b)))
             j    (- l0 (length (member n2 (mapcar 'atof (mapcar 'car cas:b)))))
             str1 (car (nth j cas:b))
             str2 (rtos (cadr (nth j cas:b)) 2 2)
             cas:b(subst (cons (rtos n1 2 0) (cadr (nth j cas:b))) (nth j cas:b) cas:b)
             i    (1+ i)
       )
       (ca_mktext str1 (trans pt1 1 0))
       (ca_mktext str2 (trans pt2 1 0))
     )
    )
  )
  (princ)
)

(defun c:dtw(/ se1 se0 l1 pt1 e01 e02 y n1 e20 t1 olderr ca:r n ens oldsnp oldzin)
  (command "color" (getvar "cecolor"))
  (setq olderr *error*)
  (setq oldsnp (getvar "osmode"))
  (setq oldzin (getvar "dimzin"))
  (setvar "osmode" 0)
  (setvar "dimzin" 0)
  (setq *error* newerr)
  (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(ca_trans 10 e01))
              n1 (atof (ca_f (cdr(assoc 1 e01))))
              pt1(list (car pt1) y 0)
              n1 (rtos (* pi n1 n1 0.0019625) 2 3)
        )
        (if (not ca:r) (setq ca:r (assoc 50 e01)))
        (ca_mktext n1 (trans pt1 1 0))
      )
    )
    (princ "\n未选择物体.")
  )
  (if oldsnp (setvar "osmode" oldsnp))
  (if oldzin (setvar "dimzin" oldzin))
  (setq *error* olderr)
  (princ)
)

(defun c:cat(/ se1 l1 pt1 e01 n1 i olderr ca:r oldsnp oldzin)
  (command "color" (getvar "cecolor"))
  (setq olderr *error*)
  (setq oldsnp (getvar "osmode"))
  (setq oldzin (getvar "dimzin"))
  (setvar "osmode" 0)
  (setvar "dimzin" 0)
  (setq *error* newerr)
  (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)
        )
        (if (not ca:r) (setq ca:r (assoc 50 e01)))
      )
      (ca_mktext (rtos nt 2 2) (trans pt1 1 0))
    )
    (princ "\n未选择物体.")
  )
  (if oldsnp (setvar "osmode" oldsnp))
  (if oldzin (setvar "dimzin" oldzin))
  (setq *error* olderr)
  (princ)
)

(defun c:cas(/ olderr se1 se2 a_ l0 l1 l2 pt1 pt2 pt1x pt2x pt1y cas:b j n1 n2
             c l str1 str2 ii b0 n ca:r ens oldsnp oldzin)
  (command "color" (getvar "cecolor"))
  (setq olderr *error*)
  (setq oldsnp (getvar "osmode"))
  (setq oldzin (getvar "dimzin"))
  (setvar "osmode" 0)
  (setvar "dimzin" 0)
  (setq *error* newerr)
  (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 (= 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 (= ca:l_ nil)
    (progn
      (if (>= ca:hh 1.0)
        (setq ca:l_ (* (expt 10.0 (+ (fix (/ (log ca:hh) (log 10))) 1)) 0.8))
        (setq ca:l_ (* (expt 10.0 (fix (/ (log ca:hh) (log 10)))) 0.8))
      )
    )
  )
  (setq cas:b nil ca:j_m 2)
  (if (= a_ 1) (cas_main))
  (if oldsnp (setvar "osmode" oldsnp))
  (if oldzin (setvar "dimzin" oldzin))
  (setq *error* olderr)
  (princ)
)

(defun c:ca(/ se0 se1 se2 se3 l1 l2 l3 a_ e01 e02 e03 n6_ e20 y olderr c oldzin
            pt1 pt2 pt3 ptx1 ptx2 ptx3 n1 n2 n3 n4 n5 n6 n ens ca:r oldsnp)
  (command "color" (getvar "cecolor"))
  (setq olderr *error*)
  (setq oldsnp (getvar "osmode"))
  (setq oldzin (getvar "dimzin"))
  (setvar "osmode" 0)
  (setvar "dimzin" 0)
  (setq *error* newerr)
  (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.01 ca:c_m "cm"))
  (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)))
  (if oldsnp (setvar "osmode" oldsnp))
  (if oldzin (setvar "dimzin" oldzin))
  (setq *error* olderr)
  (princ)
)



(if (or (= (type c:cal) 'LIST) (= (type c:cal) 'SUBR) (= (type c:cal) nil)) (arxload "geomcal.arx"))
(princ "\n**钢筋表计算。版本号 4.12,作者：南京市市政设计研究院 嵇龙。**" )
(princ "\n**************************************************************")
(princ "\n CA -- 钢筋表计算。")
(princ " DTW -- 钢筋单位重计算。")
(princ "\n CAT -- 钢筋重量合计。")
(princ " CAS -- 统计钢筋长度或重量。")
(princ)
;;文本工具一——计算器程序，对AutoCad实体操作，支持R14及R2K版本。主要对数字实体
;;进行四则运算，数字可包含简单四则运算符号“+ - * / ( )”可用“X”及“x”代替乘
;;号，整数可以突破±32767，但式中不可含有中文四则运算符号。
;;自由软件，欢迎复制、修改。作者：南京市市政设计研究院 嵇龙(ll_j@21cn.com)
;;                                                            025－3283626

(defun ce_def()

(defun newerr(s)
  (if (= s "Function cancelled")
    (progn
      (setq *error* olderr)
      (if oldsnp (setvar "osmode" oldsnp))
      (if oldzin (setvar "dimzin" oldzin))
      (ce_undef)
    )
  )
  (princ)
)

(defun mktext1(:sty :str :pt10 :j72 :j73)  ;写文字，参考实体
  (setq :sty (cdr (entget :sty))
        :pt10(trans :pt10 1 0)
        :sty (subst (cons 1 :str) (assoc 1 :sty) :sty)
        :sty (subst (cons 10 :pt10) (assoc 10 :sty) :sty)
        :sty (subst (cons 11 :pt10) (assoc 11 :sty) :sty)
        :sty (subst (cons 72 :j72) (assoc 72 :sty) :sty)
        :sty (subst (cons 73 :j73) (assoc 73 :sty) :sty)
  )
  (entmake :sty)
)

(defun mktext2(:str :pt10 :j72 / :sty)  ;写文字
  (setq        :pt10(trans :pt10 1 0))
  (entmake
    (list
      '(0 . "TEXT")
      (cons 1 :str)
      (cons 10 :pt10)
      (cons 11 :pt10)
      (cons 7 (setq :sty(getvar "textstyle")))
      (cons 40 (getvar "textsize"))
      (cons 41 (cdr (assoc 41 (tblsearch "style" :sty))))
;      (cons 50 alf)
      (cons 51 (cdr (assoc 50 (tblsearch "style" :sty))))
      '(71 . 0)
      (cons 72 :j72)
    )
  )
)

(defun ce_strtrim (s)
  (cond
    ((/= (type s) 'str) nil)
    (t (ce_strltrim (ce_strrtrim s)))
  )
)

(defun ce_strltrim (s)
  (cond
    ((eq s "") s)
    ((/= " " (substr s 1 1)) s)
    (t (ce_strltrim (substr s 2)))
  )
)

(defun ce_strrtrim (s)
  (cond
    ((eq s "") s)
    ((/= " " (substr s (strlen s) 1)) s)
    (t (ce_strrtrim (substr s 1 (1- (strlen s)))))
  )
)

(defun ce_gi(e1) ;角度转换算式，过滤文字实体
  (setq nt "")
  (while (/= e1 "")
    (setq t1 (substr e1 1 1) e1 (substr e1 2))
    (cond
      ((or (/= (member t1 '("." "'" "d" "D" "\"" "r" "R" "n" "N" "s" "S" "e" "E" "w" "W" "g" "G")) nil)
           (and (>= (ascii t1) 48) (<= (ascii t1) 57))
       )
       (setq nt (strcat nt t1))
      )
      ((= t1 "%")
       (setq e1(substr e1 2))
      )
      (t (setq nt1 1))
    )
  )
  (if (angtof nt) (setq e1 nt) (setq nt1 1))
)  

(defun ce_n(e1 / t1 nt1) ;四则运算转换算式，过滤文字实体
  (setq nt "" nt1 "" nt0 nil)
  (setq e1 (ce_strtrim e1))
  (while (and (/= e1 "") (= nt0 nil))
    (setq t1 (substr e1 1 1) e1 (substr e1 2))
    (if (or (/= (member t1 '("." "'" "d" "D" "\"" "+" "-" "*" "/" "(" ")")) nil)
            (and (>= (ascii t1) 48) (<= (ascii t1) 57))
      )
      (setq nt1 (strcat nt1 t1))
      (progn
        (if (or (= t1 "x") (= t1 "X"))
          (setq t1 "*")
          (if (or (and (>= (ascii t1) 65) (<= (ascii t1) 90))
                  (and (>= (ascii t1) 97) (<= (ascii t1) 122))
              )
            (setq t1 "")
            (setq nt0 1)
          )
        )
        (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 (and (/= nt1 "") (= nt0 nil))
    (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))
  )
  (if (and (= nt0 nil) (/= nt "")) (setq e1 (c:cal nt)) (setq e1 0.0))   
)

(defun ce_maxy(se l)  ;提取y值最大的实体
  (setq e0 (ssname se 0))
  (setq en0(entget e0)
        y0 (cadr (ce_txt_0 e0 0))
        i 0
        se3 (ssadd)
  )
  (if (> l 1)
    (repeat (- l 1)
      (setq i  (+ i 1)
            ei (ssname se i)
      )
      (setq eni(entget ei)
            yi (cadr (ce_txt_0 ei 0))
      )
      (if (> yi y0)
        (progn
          (ssadd e0 se3)
          (setq en0 eni y0 yi e0 ei)
        )
        (ssadd ei se3)
      )
    )
  )
)
                 
(defun ce_minx(se) ;提取x值最小的实体
  (setq e0 (ssname se 0))
  (setq en0(entget e0)
        x0 (car (ce_txt_0 e0 0))
        i 0
        se3 (ssadd)
  )
  (if (/= l1 1)
    (repeat (- l1 1)
      (setq i  (+ i 1)
            ei (ssname se i)
      )
      (setq eni(entget ei)
            xi (car (ce_txt_0 ei 0))
      )
      (if (<= xi x0)
        (progn
          (ssadd e0 se3)
          (setq en0 eni x0 xi e0 ei)
        )
        (ssadd ei se3)
      )
    )
  )
)

(defun ce_txt_0(ent j73 / pt0 h obl) ;文本左基点
  (setq ent (entget ent)
        pt0 (trans (cdr (assoc 10 ent)) 0 1)
        h   (cdr (assoc 40 ent))
        alf (atan (/ (cadr (setq obl (getvar "ucsxdir"))) (car obl)))
        alf (- (cdr (assoc 50 ent)) alf)
;        alf (cdr (assoc 50 ent))
        obl (cdr (assoc 51 ent))
  )
  (if (and (= j73 0) (/= (cdr (assoc 72 ent)) 4))
    (setq j73 0)
    (if (= j73 1)
      (setq j73 (/ h -3))
      (setq j73 (* (abs (- j73 1)) 0.5 h))
    )
  )
  (list (- (car pt0) (* j73 (sin alf)))
        (+ (cadr pt0) (* j73 (cos alf)))
        (caddr pt0)
  )
)

(defun ce_txt_1(ent j73 / lx) ;文本中基点
  (setq en  (entget ent)
        h   (cdr (assoc 40 en))
        alf (atan (/ (cadr (setq obl (getvar "ucsxdir"))) (car obl)))
        alf (- (cdr (assoc 50 en)) alf)
        obl (cdr (assoc 51 en))
        lx  (- (caadr (textbox en)) (/ (* h (sin obl) 2) (cos obl) 3) (/ -1.0 7))
  )
  (list (+ (* lx (cos alf) 0.5) (car (ce_txt_0 ent j73)))
        (+ (* lx (sin alf) 0.5) (cadr (ce_txt_0 ent j73)))
        (caddr (ce_txt_0 ent j73))
  )
)

(defun ce_txt_2(ent j73 / lx h en obl) ;文本右基点
  (setq en  (entget ent)
        h   (cdr (assoc 40 en))
        alf (atan (/ (cadr (setq obl (getvar "ucsxdir"))) (car obl)))
        alf (- (cdr (assoc 50 en)) alf)
        obl (cdr (assoc 51 en))
        lx  (- (caadr (textbox en)) (/ (* h (sin obl) 2) (cos obl) 3))
  )
  (list (+ (* lx (cos alf)) (car (ce_txt_0 ent j73)))
        (+ (* lx (sin alf)) (cadr (ce_txt_0 ent j73)))
        (caddr (ce_txt_0 ent j73))
  )
)

(defun ce_l_c(/ h1 se4 en0 x1 x2 y1 y2 dy e1 e2) ;判断行列模式
  (cond
    ((> l1 1)
     (ce_maxy se1 l1)
     (setq e1 (entget e0)
           h1 (cdr (assoc 40 e1))
           y1 (cadr (ce_txt_0 e0 0))
           se4 se3
           en1 en0
     )
     (ce_maxy se4 (- l1 1))
     (setq y2 (cadr (ce_txt_0 e0 0))
           dy (abs (- y1 y2))
     )
     (if (> dy h1)
       (progn
         (setq lc "列")
         (ce_maxy se1 l1)
       )
       (progn
         (setq lc "行")
         (ce_minx se1)
       )
     )
    )
    ((and (= l1 1) (/= se2 nil))
     (setq e1 (ssname se1 0)
           x1 (car (ce_txt_0 e1 0))
           y1 (cadr (ce_txt_0 e1 0))
           e2 (ssname se2 0)
           x2 (car (ce_txt_0 e2 0))
           y2 (cadr (ce_txt_0 e2 0))
     )
     (if (>= (abs (- y1 y2)) (abs (- x2 x1)))
       (progn
         (setq lc "行")
         (ce_minx se1)
       )
       (progn
         (setq lc "列")
         (ce_maxy se1 l1)
       )
     )
    )
    (t (setq lc "列")
       (ce_maxy se1 l1)
    )
  )
  (if (= sty nil)
    (setq sty  "First"
          sty1 (strcat "第一" lc "首")
    )
  )
)
               
                 
(defun ce_sele() ;拾取计算文本
  (prompt "\n选取第二组数字，或回车后键入一个数字。")
  (setq se2 (ssget '((0 . "TEXT"))))
  (cond
    ((/= se2 nil)
     (setq l2 (sslength se2))
     (cond
       ((= l2 l1) (ce_l_c) (ce_js1))
       (t (princ "\n两组数字长度不同! ") (ce_sele))
     )
    )
    (t (ce_num))
  )
)
  
(defun ce_num() ;输入计算数值
  (setq n2 (getreal "\n键入一个数字，或回车后选取第二组数字："))
  (cond
    ((/= n2 nil) (ce_l_c) (ce_js2))
    (t (ce_sele))
  )
)

(defun ce_pick_txt() ;拾取参考文本
  (while (not (setq sty_e (car (entsel "\n拾取参考文本：")))))
  (while (/= (cdr (assoc 0 (entget sty_e))) "TEXT") (ce_pick_txt))
)

(defun ce_j() ;调整文字插入方式
  (setq stye e0
        j72(cdr (assoc 72 (entget stye)))
        j73(cdr (assoc 73 (entget stye)))
  )
  (if (= j_m nil)
    (if (= j72 4)
      (setq j72 1 j_m72 1 j73 2 j_m "中")
      (if (= j72 0)
        (setq j_m72 0 j_m "左")
        (if (= j72 1)
          (setq j_m72 1 j_m "中")
          (setq j_m72 2 j_m "右")
        )
      )
    )
    (if (= j72 4) (setq j73 2))
  )
)

(defun ce_js1() ;双选择集计算
  (ce_j)
  (if (= out nil)
    (setq out  "0"
          out0 "平均二"
    )
  )
  (if (or (= out "0") (= out "3") (= out "4"))
    (setq jj (strcat "\n文本风格：" sty1 "；对齐方式：" j_m "；"))
    (setq jj "")
  )
  (princ (strcat "\n当前为\"" lc "\"模式；输出方式：" out0 lc "；"
                 jj "小数位数：" (itoa p_) "；比例：" (rtos scal 2) "。" ))
  (cond
    ((and (= lc "列") (or (= out "0") (= out "3") (= out "4")))
     (initget 1 "Mode Outmode Precision Justify Style scaLe")
     (setq pt1 (getpoint (strcat "\n改变行列模式M/输出方式O/文本风格S/对齐方式J/小数位数P/比例L/<"
               j_m "对齐线>：")))
    )
    ((and (= lc "行") (or (= out "0") (= out "3") (= out "4")))
     (initget 1 "Mode Outmode Precision Justify Style scaLe")
     (setq pt1 (getpoint
              "\n\n改变行列模式M/输出方式O/文本风格S/对齐方式J/小数位数P/比例L/<文本基线>："))
    )
    ((or (= out "1") (= out "2"))
     (initget "Mode Outmode Precision scaLe")
     (setq pt1 (getkword "\n\n改变行列模式M/输出方式O/小数位数P/比例L/<回车确认>："))
    )
    (t nil)
  )
  (cond
    ((= pt1 "Mode")
     (if (= lc "列")
       (progn
         (setq lc "行")
         (ce_minx se1)
       )
       (progn
         (setq lc "列")
         (ce_maxy se1 l1)
       )
     )
     (ce_js1)
    )
    ((= pt1 "Outmode")
     (initget "1 2 3 4")
     (setq out (getkword (strcat "\n改写第一" lc           "1/改写第二"
                                 lc              "2/对齐第一" lc
                                 "3/对齐第二" lc           "4/<平均二"
                                 lc              ">:"
                                )
               )
     )
     (cond
       ((= out "1") (setq out0 "改写第一"))
       ((= out "2") (setq out0 "改写第二"))
       ((= out "3") (setq out0 "对齐第一"))
       ((= out "4")
        (setq out0 "对齐第二")
        (if (= lc "行")
          (ce_minx se2)
          (ce_maxy se2 l1)
        )
       )
       ((= out nil)
        (setq out  "0"
              out0 "平均二"
        )
       )
       (t nil)
     )
     (ce_js1)
    )
    ((= pt1 "Style")
     (initget "First Picked")
     (setq
       sty (getkword
             (strcat "\n文本风格：第一" lc "首F/拾取P/<系统当前>：")
           )
     )
     (cond
       ((= sty "First")
        (setq sty1 (strcat "第一" lc "首"))
       )
       ((= sty "Picked")
        (setq sty1 "拾取")
        (ce_pick_txt)
        (setq e0 sty_e)
       )
       ((= sty nil)
        (setq sty  "Standard"
              sty1 "系统当前"
        )
       )
       (t nil)
     )
     (ce_js1)
    )
    ((= pt1 "Precision")
     (setq p_p (getint (strcat "\n小数位数<" (itoa p_) ">: ")))
     (if (/= p_p nil)
       (setq p_ p_p)
     )
     (ce_js1)
    )
    ((= pt1 "scaLe")
     (setq sca_ (getreal (strcat "\n比例系数<" (rtos scal 2) ">: ")))
     (if (/= sca_ nil)
       (setq scal sca_)
     )
     (ce_js1)
    )
    ((= pt1 "Justify")
     (setq j_m72 (rem (1+ j_m72) 3))
     (cond
       ((= j_m72 0) (setq j_m "左"))
       ((= j_m72 1) (setq j_m "中"))
       ((= j_m72 2) (setq j_m "右"))
       (t nil)
     )
     (ce_js1)
    )
    (t
     (setq i  -1
           n0 0
     )
     (if (= sty "First") (setq sty_e stye))
     (cond
       ((= lc "列")
        (while (/= l1 0)
          (ce_maxy se1 l1)
          (setq        se1 se3
                e01 e0
                e1  (entget e0)
          )
          (ce_maxy se2 l1)
          (setq        se2 se3
                e02 e0
                e2  (entget e0)
          )
          (setq l1 (sslength se1))
          (setq        n1 (ce_n (cdr (assoc 1 e1))))
          (if (or (= nt0 1) (= nt "")) (setq n0 "无法计算！") (setq n0 nil))
          (setq n2 (ce_n (cdr (assoc 1 e2))))
          (if (or (= nt0 1) (= nt "") (= n0 "无法计算！"))
            (setq n0 "无法计算！")
            (setq n0 (rtos (* (ce_a1 n1 n2) scal) 2 p_))
          )
          (setq y1 (cadr (eval (read (strcat "(ce_txt_" (itoa j_m72) " e01 j73)"))))
                y2 (cadr (eval (read (strcat "(ce_txt_" (itoa j_m72) " e02 j73)"))))
          )
          (cond
            ((= out "0")
             (setq y   (* 0.5 (+ y1 y2))
                   pt1 (list (car pt1) y 0))
             (if (or (= sty "First")(= sty "Picked"))
               (mktext1 sty_e n0 pt1 j_m72 j73)
               (mktext2 n0 pt1 j_m72)
             )
            )
            ((= out "3")
             (setq pt1 (list (car pt1) y1 0))
             (if (or (= sty "First")(= sty "Picked"))
               (mktext1 sty_e n0 pt1 j_m72 j73)
               (mktext2 n0 pt1 j_m72)
             )
            )
            ((= out "4")
             (setq pt1 (list (car pt1) y2 0))
             (if (or (= sty "First")(= sty "Picked"))
               (mktext1 sty_e n0 pt1 j_m72 j73)
               (mktext2 n0 pt1 j_m72)
             )
            )
            ((= out "1")
             (setq e1 (subst (cons 1 n0) (assoc 1 e1) e1))
             (entmod e1)
             (entupd e01)
            )
            ((= out "2")
             (setq e2 (subst (cons 1 n0) (assoc 1 e2) e2))
             (entmod e2)
             (entupd e01)
            )
            (t nil)
          )
        )
       )
       ((= lc "行")
        (while (/= l1 0)
          (ce_minx se1)
          (setq        se1 se3
                e01 e0
                e1  (entget e0)
          )
          (ce_minx se2)
          (setq        se2 se3
                e02 e0
                e2  (entget e0)
          )
          (setq l1 (sslength se1))
          (setq        n1 (ce_n (cdr (assoc 1 e1))))
          (if (or (= nt0 1) (= nt "")) (setq n0 "无法计算！") (setq n0 nil))
          (setq n2 (ce_n (cdr (assoc 1 e2))))
          (if (or (= nt0 1) (= nt "") (= n0 "无法计算！"))
            (setq n0 "无法计算！")
            (setq n0 (rtos (* (ce_a1 n1 n2) scal) 2 p_))
          )
          (setq x1 (car (eval (read (strcat "(ce_txt_" (itoa j_m72) " e01 j73)"))))
                x2 (car (eval (read (strcat "(ce_txt_" (itoa j_m72) " e02 j73)"))))
          )
          (cond
            ((= out "0")
             (setq x   (* 0.5 (+ x1 x2))
                   pt1 (cons x (cdr pt1))
             )
             (if (or (= sty "First")(= sty "Picked"))
               (mktext1 sty_e n0 pt1 j_m72 j73)
               (mktext2 n0 pt1 j_m72)
             )
            )
            ((= out "3")
             (setq pt1 (cons x1 (cdr pt1)))
             (if (or (= sty "First")(= sty "Picked"))
               (mktext1 sty_e n0 pt1 j_m72 j73)
               (mktext2 n0 pt1 j_m72)
             )
            )
            ((= out "4")
             (setq pt1 (cons x2 (cdr pt1)))
             (if (or (= sty "First")(= sty "Picked"))
               (mktext1 sty_e n0 pt1 j_m72 j73)
               (mktext2 n0 pt1 j_m72)
             )
            )
            ((= out "1")
             (setq e1 (subst (cons 1 n0) (assoc 1 e1) e1))
             (entmod e1)
             (entupd e01)
            )
            ((= out "2")
             (setq e2 (subst (cons 1 n0) (assoc 1 e2) e2))
             (entmod e2)
             (entupd e01)
            )
            (t nil)
          )
        )
       )
       (t nil)
     )
    )
  )
)

(defun ce_js2 () ;单选择集计算
  (ce_j)
  (if (= out nil) (setq out "新写"))
  (if (= out "新写") (setq jj (strcat "\n文本风格：" sty1 "；对齐方式：" j_m "；"))(setq jj ""))
  (princ (strcat "\n当前为\"" lc "\"模式；输出方式：" out "；" jj "小数位数：" (itoa p_) "。"))
  (cond
    ((and (= lc "列") (= out "新写"))
     (initget 1 "Mode Outmode Precision Justify Style")
     (setq pt1
            (getpoint (strcat
               "\n改变行列模式M/输出方式O/文本风格S/对齐方式J/小数位数P/<" j_m "对齐线>："
             )
           )
     )
    )
    ((and (= lc "行") (= out "新写"))
     (initget 1 "Mode Outmode Precision Justify Style")
     (setq pt1
            (getpoint
              "\n改变行列模式M/输出方式O/文本风格S/对齐方式J/小数位数P/<文本基线>："
            )
     )
    )
    ((= out "改写")
     (initget "Mode Outmode Precision")
     (setq pt1 (getkword
                 "\n\n改变行列模式M/输出方式O/小数位数P/<回车确认>："
               )
     )
    )
    (t nil)
  )
  (cond
    ((= pt1 "Mode")
     (if (= lc "列")
       (progn
         (setq lc "行")
         (ce_minx se1)
       )
       (progn
         (setq lc "列")
         (ce_maxy se1 l1)
       )
     )
     (ce_js2)
    )
    ((= pt1 "Outmode")
     (if (= out "新写")
       (setq out "改写")
       (setq out "新写")
     )
     (ce_js2)
    )
    ((= pt1 "Style")
     (initget "First Picked")
     (setq sty (getkword (strcat "\n文本风格：" lc "首F/拾取P/<系统当前>：")))
     (cond
       ((= sty "First")
        (setq sty1 (strcat lc "首"))
       )
       ((= sty "Picked")
        (setq sty1 "拾取")
        (ce_pick_txt)
        (setq e0 sty_e)
       )
       ((= sty nil)
        (setq sty  "Standard"
              sty1 "系统当前"
        )
       )
       (t nil)
     )
     (ce_js2)
    )
    ((= pt1 "Precision")
     (setq p_p (getint (strcat "\n小数位数<" (itoa p_) ">: ")))
     (if (/= p_p nil)
       (setq p_ p_p)
     )
     (ce_js2)
    )
    ((= pt1 "Justify")
     (setq j_m72 (rem (1+ j_m72) 3))
     (cond
       ((= j_m72 0) (setq j_m "左"))
       ((= j_m72 1) (setq j_m "中"))
       ((= j_m72 2) (setq j_m "右"))
       (t nil)
     )
     (ce_js2)
    )
    (t
     (setq i  -1
           n0 0
     )
     (if (= sty "First") (setq sty_e stye))
     (cond
       ((= lc "列")
        (while (/= l1 0)
          (ce_maxy se1 l1)
          (setq        se1 se3
                e01 e0
                e1  (entget e0)
                l1 (sslength se1)
          )
          (if (= ce_a1 "chaG")
            (setq n1 (ce_gi (cdr (assoc 1 e1))))
            (setq n1 (ce_n (cdr (assoc 1 e1))))
          )
          (cond
            ((= ce_a1 "Reci")
             (if (/= n1 0)
               (progn
                 (if (or (= nt0 1) (= nt ""))
                   (setq n0 "非法计算！")
                   (setq n0 (rtos (/ 1.0 n1) 2 p_))
                 )
               )
               (setq n0 "除数为零！")
             )
            )
            ((= ce_a1 "Pow")
             (if (and (< n1 0.0) (/= n2 (fix n2)))
               (setq n0 "无法求幂！")
               (progn
                 (if (or (= nt0 1) (= nt ""))
                   (setq n0 "非法计算！")
                   (setq n0 (rtos (expt n1 n2) 2 p_))
                 )
               )
             )
            )
            ((= ce_a1 "chaG")
             (if (= nt1 1)
               (setq n0 "不能转换！")
               (setq n0 (angtos (angtof n1) (- n2 1) p_))
             )
            )
            (t
             (if (or (= nt0 1) (= nt ""))
               (setq n0 "无法计算！")
               (setq n0 (rtos (* (ce_a1 n1 n2) scal) 2 p_))
             )
            )
          )
          (setq y (cadr (eval (read (strcat "(ce_txt_" (itoa j_m72) " e01 j73)")))))
          (cond
            ((= out "新写")
             (setq pt1 (list (car pt1) y 0)
             )
             (if (or (= sty "First")(= sty "Picked"))
               (mktext1 sty_e n0 pt1 j_m72 j73)
               (mktext2 n0 pt1 j_m72)
             )
            )
            ((= out "改写")
             (if (/= nt1 1)
               (progn
                 (setq e1 (subst (cons 1 n0) (assoc 1 e1) e1))
                 (entmod e1)
                 (entupd e01)
               )
             )
            )
            (t nil)
          )
          (setq nt1 nil)
        )
       )
       ((= lc "行")
        (while (/= l1 0)
          (ce_minx se1)
          (setq        se1 se3
                e01 e0
                e1  (entget e0)
                l1  (sslength se1)
          )
          (if (= ce_a1 "chaG")
            (setq n1 (ce_gi (cdr (assoc 1 e1))))
            (setq n1 (ce_n (cdr (assoc 1 e1))))
          )
          (cond
            ((= ce_a1 "Reci")
             (if (/= n1 0.0)
               (progn
                 (if (or (= nt0 1) (= nt ""))
                   (setq n0 "非法计算！")
                   (setq n0 (rtos (/ 1.0 n1) 2 p_))
                 )
               )
               (setq n0 "除数为零！")
             )
            )
            ((= ce_a1 "Pow")
             (if (and (< n1 0.0) (/= n2 (fix n2)))
               (setq n0 "无法求幂！")
               (progn
                 (if (or (= nt0 1) (= nt ""))
                   (setq n0 "非法计算！")
                   (setq n0 (rtos (expt n1 n2) 2 p_))
                 )
               )
             )
            )
            ((= ce_a1 "chaG")
             (if (= nt1 1)
               (setq n0 "不能转换！")
               (setq n0 (angtos (angtof n1) (- n2 1) p_))
             )
            )
            (t
             (if (or (= nt0 1) (= nt ""))
               (setq n0 "无法计算！")
               (setq n0 (rtos (* (ce_a1 n1 n2) scal) 2 p_))
             )
            )
          )
          (setq x (car (eval (read (strcat "(ce_txt_" (itoa j_m72) " e01 j73)")))))
          (cond
            ((= out "新写")
             (setq pt1 (cons x (cdr pt1)))
             (if (or (= sty "First")(= sty "Picked"))
               (mktext1 sty_e n0 pt1 j_m72 j73)
               (mktext2 n0 pt1 j_m72)
             )
            )
            ((= out "改写")
             (if (/= nt1 1)
               (progn
                 (setq e1 (subst (cons 1 n0) (assoc 1 e1) e1))
                 (entmod e1)
                 (entupd e01)
               )
             )
            )
            (t nil)
          )
          (setq nt1 nil)
        )
       )
       (t nil)
     )
    )
  )
)

(defun ce_tot (/ ei ni n0) ;求和子程序
  (ce_j)
  (princ (strcat "\n对齐方式：" j_m "；小数位数：" (itoa p_) "。"))
  (initget 1 "Precision Justify")
  (setq pt1 (getpoint (strcat "\n小数位数P/对齐方式J/<" j_m "对齐点>：")))
  (cond
    ((= pt1 "Precision")
     (setq p_p (getint "\n小数位数："))
     (if (/= p_p nil)
       (setq p_ p_p)
     )
     (ce_tot)
    )
    ((= pt1 "Justify")
     (setq j_m72 (rem (1+ j_m72) 3))
     (cond
       ((= j_m72 0) (setq j_m "左"))
       ((= j_m72 1) (setq j_m "中"))
       ((= j_m72 2) (setq j_m "右"))
       (t nil)
     )
     (ce_tot)
    )
    (t (setq i  -1  n0 0)
     (repeat l1
       (setq i        (+ i 1)
             ei        (entget (ssname se1 i))
             ni        (ce_n (cdr (assoc 1 ei)))
             n0        (+ n0 ni)
       )
     )
     (mktext2 (rtos n0 2 p_) pt1 j_m72)
    )
  )
)

(defun ce_pow() ;乘方子程序
  (initget 1)
  (setq n2 (getreal "\n键入一个实数幂："))
  (ce_l_c)
  (ce_js2)
)

(defun ce_chag() ;角度转换子程序
  (initget 1 "1 2 3 4 5")
  (setq n2 (atoi (getkword "\n选择角度转换方式：1.度；2.度分秒；3.百分度；4.弧度；5.勘测单位：")))
  (setq nt1 nil)
  (ce_l_c)
  (ce_js2)
)
  
(defun ce_undef        ()
  (mapcar
    '(lambda (x)
       (setq x nil)
     )
    '(newerr          mktext1     mktext2          ce_strtrim  ce_strrtrim
      ce_strltrim ce_gi              ce_n          ce_maxy     ce_minx
      ce_txt_0          ce_txt_1    ce_txt_2          ce_l_c      ce_sele
      ce_num          ce_pick_txt ce_j          ce_js1      ce_js2
      ce_tot          ce_pow      ce_chag
     )
  )
)

)         ;End ce_def


(defun c:ce(/ out   out0  jj        ce_a1 lc    p_p          l1        i     pt1
              e01   e02          en0        eni   e0    e1          e2        ei    alf
              se1   se2          se3        se4   nt    nt0          nt1        sr0   sri
              n0    n1          n2        n3    j_m   j_m72 j72        j73   oldzin
              sty   sty1  stye        sty_e x            x1          x2        xi    x0
              y            y0          yi        scal  sca_| oldsnp        ce_undef
             )                                ;主程序
  (command "color" (getvar "cecolor"))
  (ce_def)
  (setq olderr *error*)
  (setq oldsnp (getvar "osmode"))
  (setq oldzin (getvar "dimzin"))
  (setvar "osmode" 0)
  (setvar "dimzin" 0)
  (setq *error* newerr)
  (princ "\n选取第一组数字: ")
  (setq se1 (ssget '((0 . "TEXT"))))
  (if se1
    (progn
      (setq l1 (sslength se1)
            i -1
            scal 1.0
      )
      (if (not p_) (setq p_ 2))
      (initget 0 "Total Reci chaG Pow Add Sub Mult Div + - * /")
      (setq ce_a1 (getkword "\n求和T/倒数R/乘方P/角度转换G/加A(+)/减S(-)/除以D(/)/<乘M(*)> :"))
      (cond
        ((= ce_a1 "Total") (ce_l_c) (ce_tot))
        ((or (= ce_a1 "Add") (= ce_a1 "+")) (setq ce_a1 +) (ce_sele))
        ((or (= ce_a1 "Sub") (= ce_a1 "-")) (setq ce_a1 -) (ce_sele))
        ((or (= ce_a1 "Mult") (= ce_a1 "*") (= ce_a1 "") (= ce_a1 nil)) (setq ce_a1 *) (ce_sele))
        ((or (= ce_a1 "Div") (= ce_a1 "/")) (setq ce_a1 /) (ce_sele))
        ((= ce_a1 "Reci") (ce_l_c) (ce_js2))
        ((= ce_a1 "Pow") (ce_pow))
        ((= ce_a1 "chaG") (ce_chag))
        (t nil)
      )
    )
    (princ "\n未选择物体。\n")
  )
  (if oldsnp (setvar "osmode" oldsnp))
  (if oldzin (setvar "dimzin" oldzin))
  (setq *error* olderr)
  (ce_undef)
  (princ)
)

(if (or        (= (type c:cal) 'LIST)    ;R14
        (= (type c:cal) 'SUBR)    ;R15
        (= (type c:cal) nil)      ;R16
    )
  (arxload "geomcal.arx")
)
(princ "\n**计算器,自由软件,版本号 2.14,作者：南京市市政设计研究院 嵇龙。**" )
(princ "\n**命令：ce")

;;文本编辑扩展工具，文本修改后变换颜色显示。可以设置ddedit命令修改后文本
;;的颜色，默认为当前系统颜色号加一，确认不修改为修改文本颜色号加一。
;;作者：南京市市政设计研究院 嵇龙(ll_j@21cn.com)
;;                                  025－3283626

(defun ett_ct()
  (initget "C  ")
  (setq s0 (entsel "\n设置颜色C / 选取文本:"))
  (cond
    ( (= s0 "C") (ett_col))
    ( (= s0 "") nil)
    ( (and (= (type s0) 'LIST) (= (cdr (assoc 0 (entget (car s0)))) "TEXT"))
      (redraw (setq sn (car s0)) 3)
      (setq s1 (entget sn)
            n1 (cdr (assoc 1 s1))
      )
      (command "_.DDEDIT" sn "")
      (entupd sn)
      (if (/= n1 (cdr (assoc 1 (entget sn))))
        (progn
          (setq s1 (entget sn))
          (if (/= (assoc 62 s1) nil)
            (setq s1 (subst (cons 62 c2) (assoc 62 s1) s1))
            (setq s1 (cons (cons 62 c2) s1))
          )
          (entmod s1)
          (redraw sn 1)
        )
        (progn
          (setq s1 (entget sn) c3(+ c2 1))
          (if (= c3 257) (setq c3 1))
          (if (/= (assoc 62 s1) nil)
            (setq s1 (subst (cons 62 c3) (assoc 62 s1) s1))
            (setq s1 (cons (cons 62 c3) s1))
          )
          (entmod s1)
          (redraw sn 1)
        )
      )
      (setq sn nil)
      (ett_ct)
    )
    (t (ett_ct))
  )
)

(defun ett_col()
  (setq c1 c2)
  (setq c2 (acad_colordlg c2))
  (if (= c2 nil) (setq c2 c1))
  (ett_ct)
)

(defun c:ett(/ sn s0 s1 c1 c2 c3 n1)
  (setq c1 (getvar "CECOLOR"))
  (if (or (= c1 "BYLAYER") (= c1 "BYBLOCK"))
    (setq c1 1)
    (setq c1 (1+ (read c1)))
  )
  (if (= c1 256) (setq c1 1))
  (setq c2 c1)
  (princ (strcat "\n当前颜色号 " (getvar "cecolor") "，设置颜色号 " (itoa c2) "。"))
  (ett_ct)
  (princ)
)

(princ "\n**Text文本编辑扩展工具。作者：南京市市政设计研究院 嵇龙。**")
(princ "\n**命令：ett")
;;文本工具二——文本对齐工具，支持多行多列自动对齐，行列合计。
;;R2002版本，R14中根据提示修改（第71、88行）。
;;自由软件，欢迎复制、修改。作者：南京市市政设计研究院 嵇龙(ll_j@21cn.com)
;;                                                            025－3283626

(defun newerr (s)
  (if (= s "Function cancelled")
    (progn
      (setq *error* olderr)
      (if oldsnp
        (setvar "osmode" oldsnp)
      )
      (if oldzin
        (setvar "dimzin" oldzin)
      )
    )
  )
  (princ)
)

(defun ju_defun        ()                        ;定义函数
  (defun ju_txt        (j72 j73)              ;Text角点
    (if        (/= j73 0)
      (if (= j73 1)
        (setq j73 (/ h -3))
        (setq j73 (* (abs (- j73 1)) 0.5 h))
      )
    )
    (trans (list
             (- (+ (* lx (cos alf) j72 0.5) (car pt0)) (* j73 (sin alf)))
             (+ (* lx (sin alf) j72 0.5) (cadr pt0) (* j73 (cos alf)))
             (caddr pt0)
           )
           0
           1
    )
  )

  (defun ju_set        (se)                        ;将文本实体选择集转换为含实体名的表
    (setq l1   (sslength se)
          i    0
          set0 nil
    )
    (repeat l1
      (setq e0         (ssname se i)
            set0 (cons e0 set0)
            i         (1+ i)
      )
    )
  )

  (defun ju_m_pt (sign axis tname)        ;文本边缘x、y值，sign——'MIN、'MAX，axis——'CAR、'CADR...
    (setq en  (entget tname)
          h   (cdr (assoc 40 en))
          alf (cdr (assoc 50 en))
          obl (cdr (assoc 51 en))
          pt0 (cdr (assoc 10 en))
          lx  (- (caadr (textbox en))
                 (* h (/ (sin obl) (cos obl)))
              )
    )
    (setq ptlist (list (ju_txt 0 0)
                       (ju_txt 0 3)
                       (ju_txt 2 0)
                       (ju_txt 2 3)
                 )
    )
    (apply sign (mapcar axis ptlist))
  )
  
;;|                                     ;R14时行首去掉一个分号
  (defun ju_sorten (sign axis se)        ;实体按x、y排序       R2k使用
    (if        (= sign 'min)
      (setq mc <)
      (setq mc >)
    )
    (setq ss (vl-sort se
                      (function
                        (lambda        (e1 e2)
                          (mc (ju_m_pt sign axis e1) (ju_m_pt sign axis e2))
                        )
                      )
             )
    )
  )
;;|;

;|                                      ;R14时行首加一个分号
  (defun ju_sorten (sign axis se)        ;实体按x、y排序       R14使用
    (setq ss   nil
          sexy (mapcar
                 '(lambda (x)
                    (ju_m_pt sign axis x)
                  )
                 se
               )
    )
    (repeat (length se)
      (setq mc          (apply 'min sexy)
            ii          0
            i          -1
            list1 nil
            list0 nil
      )
      (while (= ii 0)
        (setq i          (1+ i)
              sei (nth i se)
              xy  (ju_m_pt sign axis sei)
        )
        (if (= mc xy)
          (setq        ss (cons sei ss)
                ii 1
          )
          (setq        list1 (cons (nth i sexy) list1)
                list0 (cons sei list0)
          )
        )
      )
      (setq sexy (append (reverse list1) (cdr (member mc sexy)))
            se         (append (reverse list0) (cdr (member sei se)))
      )
    )
    (if        (= sign 'min)
      (setq ss (reverse ss))
      (setq ss ss)
    )
  )
;;|;

  (defun ju_row        ()                        ;将实体分行
    (ju_sorten 'max 'cadr set0)
    (setq row  1
          set1 (cons (cons (car ss) row) nil)
    )
    (mapcar
      '(lambda (x)
         (if (<        (ju_m_pt 'max 'cadr x)
                (ju_m_pt 'min 'cadr (caar set1))
             )
           (setq row (1+ row))
         )
         (setq set1 (cons (cons x row) set1))
       )
      (cdr ss)
    )
    (setq set1 (reverse set1))
  )

  (defun ju_col        ()                        ;将实体分列
    (ju_sorten 'min 'car set0)
    (setq col  1
          set2 (cons (cons (car ss) col) nil)
    )
    (mapcar
      '(lambda (x)
         (setq ym nil)
         (mapcar
           '(lambda(y)
              (if (= (cdr y) col)
                (setq ym (cons (ju_m_pt 'max 'car (car y)) ym))
              )
            )
           set2
         )
         (if (>        (ju_m_pt 'min 'car x)
                (apply 'max ym)
             )
           (setq col (1+ col))
         )
         (setq set2 (cons (cons x col) set2))
       )
      (cdr ss)
    )
    (setq set2 (reverse set2))
  )

  (defun ju_rc ()                        ;判断行列模式
    (if        (and (/= row 1) (/= col 1))
      (setq rc "阵列")
      (if (/= col 1)
        (setq rc "行")
        (setq rc "列")
      )
    )
  )

  (defun ju_dist (/ dis)                ;输入行列间距
    (initget 128)
    (setq disr (getpoint "\n指定单位单元或输入行间距<自动>: "))
    (if        disr
      (if (= (type disr) 'LIST)
        (progn
          (initget 1)
          (setq dis (getcorner disr "\n指定对角点: "))
          (setq        disc (rtos (abs (- (car dis) (car disr))) 2 2)
                disr (rtos (abs (- (cadr dis) (cadr disr))) 2 2)
          )
          (if (= (distof disr) 0.0)
            (setq disr "自动")
          )
          (if (= (distof disc) 0.0)
            (setq disc "自动")
          )
        )
        (if (= (type disr) 'STR)
          (if (setq dis (distof disr))
            (if        (> dis 0.0)
              (progn
                (initget 6)
                (setq disc (getdist "\n输入列间距<自动>: "))
                (if (= disc nil)
                  (setq disc "自动")
                  (setq disc (rtos disc 2 2))
                )
              )
              (progn
                (princ "\n需要正数值或两个二维角点。")
                (ju_dist)
              )
            )
            (progn
              (princ "\n需要正数值或两个二维角点。")
              (ju_dist)
            )
          )
          (progn
            (princ "\n需要正数值或两个二维角点。")
            (ju_dist)
          )
        )
      )
      (progn
        (setq disr "自动")
        (initget 6)
        (setq disc (getdist "\n输入列间距<自动>: "))
        (if (= disc nil)
          (setq disc "自动")
          (setq disc (rtos disc 2 2))
        )
      )
    )
  )

  (defun ju_vset ()                        ;计算默认值
    (setq jus  "右"
          ju72 2
          pre  "不统一"
          sta  "不合计"
          disr "自动"
          disc "自动"
    )
    (if        (= rc "列")
      (setq ali         "右"
            ju72 2
      )
      (setq ali         "基线"
            ju73 0
      )
    )
  )

  (defun ju_mktext (str pt10 j72 j73 j50 / sty) ;make_text
    (entmake
      (list
        '(0 . "TEXT")
        (cons 1 str)
        (cons 10 pt10)
        (cons 11 pt10)
        (cons 7 (setq sty (getvar "textstyle")))
        (cons 40 (getvar "textsize"))
        (assoc 41 (tblsearch "style" sty))
        (cons 50 j50)
        (cons 51 (cdr (assoc 50 (tblsearch "style" sty))))
        '(71 . 0)
        (cons 72 j72)
        (cons 73 j73)
      )
    )
  )


  (defun ju_out        ()
    (if        (= rc "阵列")
      (ju_array)
      (ju_column_row)
    )
  )

  (defun ju_column_row ()                ;行、列模式运行结果
    (setq ptx (car pt1)
          pty (cadr pt1)
          num nil
    )
    (mapcar
      '(lambda (x)
         (setq e0 (entget x))
;|       (if (= rc "列")
           (setq ju73 (cdr (assoc 73 e0)))
           (setq ju72 (cdr (assoc 72 e0)))
         )
|;
         (if (not ju72)
           (setq ju72 (cdr (assoc 72 (entget (caar set2)))))
         )
         (if (not ju73)
           (setq ju73 (cdr (assoc 73 (entget (caar set1)))))
         )
         (if (= ju72 4)
           (setq ju72 1)
           (if (or (= ju72 5) (= ju72 6))
             (setq ju72 2)
           )
         )
         (setq en  (entget x)
               h   (cdr (assoc 40 en))
               alf (cdr (assoc 50 en))
               obl (cdr (assoc 51 en))
               pt0 (cdr (assoc 10 en))
               lx  (- (caadr (textbox en))
                      (* h (/ (sin obl) (cos obl)))
                   )
               pti (ju_txt ju72 ju73)
         )
         (if (= rc "列")
           (setq pti (trans (list ptx (cadr pti) (caddr pti)) 1 0))
           (setq pti (trans (list (car pti) pty (caddr pti)) 1 0))
         )
         (setq e0 (subst (cons 10 pti) (assoc 10 e0) e0)
               e0 (subst (cons 11 pti) (assoc 11 e0) e0)
               e0 (subst (cons 72 ju72) (assoc 72 e0) e0)
               e0 (subst (cons 73 ju73) (assoc 73 e0) e0)
         )
         (if (/= pre "不统一")
           (progn
             (setq etx (cdr (assoc 1 e0)))
             (if (distof etx)
               (setq etx (rtos (distof etx) 2 (atoi pre))
                     num (cons (atof etx) num)
                     e0         (subst (cons 1 etx) (assoc 1 e0) e0)
               )
             )
           )
           (progn
             (setq etx (cdr (assoc 1 e0)))
             (if (distof etx)
               (setq num (cons (atof etx) num))
             )
           )
         )
         (entmod e0)
       )
      set0
    )
    (if        num
      (setq num (apply '+ num))
    )
    (if        (and num (/= sta "不合计"))
      (progn
        (initget 1)
        (setq pt1 (getpoint "\n合计数字位置: "))
        (if (= rc "列")
          (setq        alf (cdr (assoc 50 (entget (caar set1))))
                pt1 (trans (list ptx (cadr pt1) (caddr pti)) 1 0)
          )
          (setq        alf (cdr (assoc 50 (entget (caar set2))))
                pt1 (trans (list (car pt1) pty (caddr pti)) 1 0)
          )
        )
        (if (= pre "不统一")
          (progn
            (setvar "dimzin" 8)
            (ju_mktext (rtos num 2) pt1 ju72 ju73 alf)
            (setvar "dimzin" oldzin)
          )
          (ju_mktext (rtos num 2 (atoi pre)) pt1 ju72 ju73 alf)
        )
      )
      (if (not num)
        (princ "\n无数值。")
      )
    )
  )

  (defun ju_in ()                        ;运行前处理
    (cond
      ((or (= rc "列") (= rc "行"))
       (princ (strcat "\n当前为\""   rc                    "\"模式; 对齐方式:"
                      ali             "; 小数位数:"  pre
                      "; 文本合计:"  sta            "。"
                     )
       )
       (initget 1 "Mode Precision Align Stat")
       (setq pt1 (getpoint "\n模式M/对齐方式A/小数位数P/合计S/<对齐基准线>: "
                 )
       )
      )
      ((and (= rc "阵列") (= disr "自动") (= disc "自动"))
       (princ (strcat "\n当前为\"阵列\"模式; 行对齐方式:"   ali
                      "; 列对齐方式:"         jus                    "; 小数位数:"
                      pre                 ";\n行距:"            disr
                      "; 列距:"                 disc                    "; 文本合计:"
                      sta                 "。"
                     )
       )
       (initget "Mode Precision Align Stat Distance Justify")
       (setq pt1
              (getkword
                "\n模式M/行对齐方式A/列对齐方式J/小数位数P/行列间距D/合计S/<回车确认>: "
              )
       )
      )
      (t
       (princ (strcat "\n当前为\"阵列\"模式; 行对齐方式:"   ali
                      "; 列对齐方式:"         jus                    "; 小数位数:"
                      pre                 ";\n行距:"            disr
                      "; 列距:"                 disc                    "; 文本合计:"
                      sta                 "。"
                     )
       )
       (initget 1 "Mode Precision Align Stat Distance Justify")
       (setq pt1
              (getpoint
                (strcat
                  "\n模式M/行对齐方式A/列对齐方式J/小数位数P/行列间距D/合计S/<任意基准点>: "
                )
              )
       )
      )
    )
    (cond
      ((= pt1 "Mode")
       (initget "Row Column Array")
       (setq rc (getkword "\n模式: 行R/列C/<阵列A>: "))
       (if (= rc "Row")
         (setq rc "行")
         (if (= rc "Column")
           (setq rc "列")
           (setq rc "阵列")
         )
       )
       (ju_in)
      )
      ((= pt1 "Align")
       (if (= rc "列")
         (progn
           (initget "Left Center Right")
           (setq ali (getkword "\n对齐方式: 左L/中C/<右R>: "))
           (if (= ali "Left")
             (setq ju72        0
                   ali        "左"
             )
             (if (= ali "Center")
               (setq ju72 1
                     ali  "中"
               )
               (setq ju72 2
                     ali  "右"
               )
             )
           )
         )
         (progn
           (initget "Top Middle Base")
           (setq ju73 (getkword "\n对齐方式: 上T/中M/<基线B>: "))
           (if (= ju73 "Top")
             (setq ju73        3
                   ali        "上"
             )
             (if (= ju73 "Middle")
               (setq ju73 2
                     ali  "中"
               )
               (setq ju73 0
                     ali  "基线"
               )
             )
           )
         )
       )
       (ju_in)
      )
      ((= pt1 "Justify")
       (initget "Left Center Right")
       (setq ju72 (getkword "\n对齐方式: 左L/中C/<右R>："))
       (if (= ju72 "Left")
         (setq ju72 0
               jus  "左"
         )
         (if (= ju72 "Center")
           (setq ju72 1
                 jus  "中"
           )
           (setq ju72 2
                 jus  "右"
           )
         )
       )
       (ju_in)
      )
      ((= pt1 "Precision")
       (initget 4)
       (setq pre (getint "\n小数位数<回车不统一>: "))
       (if (= pre nil)
         (setq pre "不统一")
         (setq pre (itoa pre))
       )
       (ju_in)
      )
      ((= pt1 "Stat")
       (if (= rc "阵列")
         (progn
           (initget "Row Column All")
           (setq
             sta (getkword "\n对齐方式: 合计行R/合计列C/全部合计A/<不合计>: "
                 )
           )
           (if (= sta "Row")
             (setq sta "合计行")
             (if (= sta "Column")
               (setq sta "合计列")
               (if (= sta "All")
                 (setq sta "全部合计")
                 (setq sta "不合计")
               )
             )
           )
         )
;|       (progn
           (initget "Total")
           (setq sta (getkword "\n合计T/<不合计>: "))
           (if (= sta "Total")
             (setq sta "合计")
             (setq sta "不合计")
           )
         )
|;
         (if (= sta "合计")
           (setq sta "不合计")
           (setq sta "合计")
         )
       )
       (ju_in)
      )
      ((= pt1 "Distance")
       (ju_dist)
       (ju_in)
      )
      (t nil)
    )
  )

  (defun ju_stas (ss xy n ;|ju72 ju73 sta pre|;) ;构造输出点及合计结果表
    (setq ss0 nil
          i   0
    )
    (repeat n
      (setq i         (+ 1 i)
            num         nil
            ptxy nil
      )
      (mapcar
        '(lambda (x)
           (if (= (cdr x) i)
             (setq en        (entget (car x))
                   h        (cdr (assoc 40 en))
                   alf        (cdr (assoc 50 en))
                   obl        (cdr (assoc 51 en))
                   pt0        (cdr (assoc 10 en))
                   lx        (- (caadr (textbox en))
                           (* h (/ (sin obl) (cos obl)))
                        )
                   ptxy        (cons (nth xy (ju_txt ju72 ju73)) ptxy)
             )
           )
         )
        ss
      )
      (cond
        ((and (= ju72 0) (= xy 0))
         (setq ptxy (apply 'MIN ptxy))
        )
        ((and (= ju72 2) (= xy 0))
         (setq ptxy (apply 'MAX ptxy))
        )
        (t (setq ptxy (/ (apply '+ ptxy) (length ptxy))))
      )
      (mapcar
        '(lambda (x)
           (if (= (cdr x) i)
             (progn
               (setq en         (entget (car x))
                     etx (cdr (assoc 1 en))
               )
               (if (and (/= sta "不合计") (distof etx))
                 (if (/= pre "不统一")
                   (setq etx (rtos (distof etx) 2 (atoi pre))
                         num (cons (atof etx) num)
                   )
                   (setq num (cons (atof etx) num))
                 )
               )
             )
           )
         )
        ss
      )
      (if num
        (setq num (apply '+ num))
      )
      (setq ss0 (cons (list ptxy num) ss0))
    )
    (reverse ss0)
  )

  (defun ju_array ()                        ;阵列模式输出结果
    (setq b1 (ju_stas set1 1 row)
          b2 (ju_stas set2 0 col)
    )
    (if        pt1
      (progn
        (if (/= disr "自动")
          (setq        b1 (mapcar
                     '(lambda (x)
                        (setq tmp (- (cadr pt1) (car x)))
                        (if (< (/ tmp (distof disr)) 0)
                          (setq tmp (fix (- (/ tmp (distof disr)) 0.500001)))
                          (setq tmp (fix (+ (/ tmp (distof disr)) 0.499999)))
                        )
                        (setq tmp (- (cadr pt1) (* tmp (distof disr))))
                        (list tmp (cadr x))
                      )
                     b1
                   )
          )
        )
        (if (/= disc "自动")
          (setq        b2 (mapcar
                     '(lambda (x)
                        (setq tmp (- (car pt1) (car x)))
                        (if (< (/ tmp (distof disc)) 0)
                          (setq tmp (fix (- (/ tmp (distof disc)) 0.500001)))
                          (setq tmp (fix (+ (/ tmp (distof disc)) 0.499999)))
                        )
                        (setq tmp (- (car pt1) (* tmp (distof disc))))
                        (list tmp (cadr x))
                      )
                     b2
                   )
          )
        )
      )
    )
    (mapcar
      '(lambda (x)
         (setq e0  (entget x)
               ix  (- (cdr (assoc x set1)) 1)
               iy  (- (cdr (assoc x set2)) 1)
               pti (trans (list        (car (nth iy b2))
                                (car (nth ix b1))
                                (nth 3 (assoc 10 e0))
                          )
                          1
                          0
                   )
               e0  (subst (cons 10 pti) (assoc 10 e0) e0)
               e0  (subst (cons 11 pti) (assoc 11 e0) e0)
               e0  (subst (cons 72 ju72) (assoc 72 e0) e0)
               e0  (subst (cons 73 ju73) (assoc 73 e0) e0)
         )
         (if (/= pre "不统一")
           (progn
             (setq etx (cdr (assoc 1 e0)))
             (if (distof etx)
               (setq etx (rtos (distof etx) 2 (atoi pre))
                     e0         (subst (cons 1 etx) (assoc 1 e0) e0)
               )
             )
           )
         )
         (entmod e0)
       )
      set0
    )
    (if        (= sta "合计行")
      (ju_sta b1 0 "\n行合计数字位置: ")
      (if (= sta "合计列")
        (ju_sta b2 1 "\n列合计数字位置: ")
        (if (= sta "全部合计")
          (progn
            (ju_sta b1 0 "\n行合计数字位置: ")
            (ju_sta b2 1 "\n列合计数字位置: ")
          )
        )
      )
    )
  )

  (defun ju_sta        (ss xy msg)                ;合计数值输出
    (setq alf (cdr (assoc 50 (entget (caar set1)))))
    (initget 1)
    (setq ptx (getpoint msg))
    (mapcar
      '(lambda (x)
         (if (= xy 0)
           (setq pt1 (trans (list (car ptx) (car x) (caddr ptx)) 1 0))
           (setq pt1 (trans (list (car x) (cadr ptx) (caddr ptx)) 1 0))
         )
         (if (setq num (cadr x))
           (if (= pre "不统一")
             (progn
               (setvar "dimzin" 8)
               (ju_mktext (rtos num 2) pt1 ju72 ju73 alf)
               (setvar "dimzin" oldzin)
             )
             (ju_mktext (rtos num 2 (atoi pre)) pt1 ju72 ju73 alf)
           )
           (princ "\n无数值。")
         )
       )
      ss
    )
  )
)

(defun c:ju (/ alf     ali     axis    b1      b2      col     dis     disc
               disr    e0      e00     ei      en      ent     etx     h
               i       ii      ix      iy      j72     j73     ju72    ju73
               jus     l1      list0   list1   lx      mc      num     obl
               olderr  oldsnp  oldzin  pre     pt_list pt0     pt1     pti
               ptx     ptxy    pty     rc      row     s       se      se3
               se4     set0    set1    set2    si      sign    ss      ss0
               sta     tname   tmp     x       x0      xi      xy      ym
               ju_array               ju_col  ju_column_row   ju_dist ju_in   ju_m_pt
               ju_mktext       ju_sorten       ju_out  ju_rc   ju_row  ju_set
               ju_sta  ju_stas ju_txt  ju_vset
              )
  (command "color" (getvar "cecolor"))
  (setq olderr *error*)
  (setq oldsnp (getvar "osmode"))
  (setq oldzin (getvar "dimzin"))
  (setvar "osmode" 0)
  (setvar "dimzin" 0)
  (setq *error* newerr)
  (princ "\n选取文本: ")
  (setq se1 (ssget '((0 . "TEXT"))))
  (if se1
    (progn
      (princ "\n请稍候...\n")
      (ju_defun)
      (ju_set se1)
      (ju_row)
      (princ "...\n")
      (ju_col)
      (ju_rc)
      (ju_vset)
      (ju_in)
      (ju_out)
    )
    (princ "\n空选择集。")
  )
  (if oldsnp
    (setvar "osmode" oldsnp)
  )
  (if oldzin
    (setvar "dimzin" oldzin)
  )
  (setq *error* olderr)
  (princ)
)


(princ "\n**文本对齐工具,自由软件,版本号 1.21,作者: 南京市市政设计研究院 嵇龙。**")
(princ "\n**命令：ju")

;;文本工具三——ACAD Text文本写入文件，支持普通文本方式及制表符方式。
;;自由软件，欢迎复制、修改。作者：南京市市政设计研究院 嵇龙(ll_j@21cn.com)
;;                                                            025－3283626

(defun wr_defun        ()
  (defun wr_set        (se)                        ;将文本实体选择集转换为含实体名的表
    (setq l1   (sslength se)
          i    0
          set0 nil
    )
    (repeat l1
      (setq e0         (ssname se i)
            set0 (cons e0 set0)
            i         (1+ i)
      )
    )
  )

  (defun wr_sorten (se axis)                ;实体按x、y排序
    (setq ss   nil
          sexy (mapcar
                 '(lambda (x)
                    (axis (trans (cdr (assoc 10 (entget x))) 0 1))
                  )
                 se
               )
    )
    (repeat (length se)
      (setq mc          (apply 'max sexy)
            ii          0
            i          -1
            list1 nil
            list0 nil
      )
      (while (= ii 0)
        (setq i          (1+ i)
              sei (nth i se)
              xy  (axis (trans (cdr (assoc 10 (entget sei))) 0 1))
        )
        (if (= mc xy)
          (setq        ss (cons sei ss)
                ii 1
          )
          (setq        list1 (cons (nth i sexy) list1)
                list0 (cons sei list0)
          )
        )
      )
      (setq sexy (append (reverse list1) (cdr (member mc sexy)))
            se         (append (reverse list0) (cdr (member sei se)))
      )
    )
    (setq ss (reverse ss))
  )

  (defun wr_row        ()                        ;将实体分行
    (wr_sorten set0 cadr)
    (setq row  1
          set1 (cons (cons (car ss) row) nil)
    )
    (mapcar
      '(lambda (x)
         (if (<        (+ (cadr (trans (cdr (assoc 10 (entget x))) 0 1))
                   (cdr (assoc 40 (entget x)))
                )
                (cadr (trans (cdr (assoc 10 (entget (caar set1)))) 0 1))
             )
           (setq row (1+ row))
         )
         (setq set1 (cons (cons x row) set1))
       )
      (cdr ss)
    )
    (setq set1 (reverse set1))
  )

  (defun wr_col        ()                        ;将实体分列
    (setq ss (reverse (wr_sorten set0 car)))
    (setq col  1
          set2 (cons (cons (car ss) col) nil)
    )
    (mapcar
      '(lambda (x)
         (setq ym nil)
         (mapcar
           '(lambda (y)
              (if (= (cdr y) col)
                (setq tmp (entget (car y))
                      ym  (cons
                            (+ (car (trans (cdr (assoc 10 tmp)) 0 1))
                               (caadr (textbox tmp))
                            )
                            ym
                          )
                )
              )
            )
           set2
         )
         (if (>        (car (trans (cdr (assoc 10 (entget x))) 0 1))
                (apply 'max ym)
             )
           (setq col (1+ col))
         )
         (setq set2 (cons (cons x col) set2))
       )
      (cdr ss)
    )
    (setq set2 (reverse set2))
  )

  (defun wr_main ()
    (while (not fn)
      (setq fn (getfiled "文本文件" "CADText" "txt" 13))
    )
    (if        (findfile fn)
      (progn
        (initget "Add Write")
        (setq fs (getkword "\n覆盖W/<附加A>: "))
        (if (= fs "Write")
          (setq fs (open fn "w"))
          (setq fs (open fn "a"))
        )
      )
      (setq fs (open fn "a"))
    )
    (initget "Normal Tab")
    (setq wmode (getkword "\n制表模式T/<普通文本N>: "))
    (if (= wmode nil)
      (setq wmode "Normal")
    )
    (wr_set se1)
    (wr_row)
    (wr_col)
    (setq ij 0)
    (repeat row
      (setq l1 nil
            ij (1+ ij)
      )
      (mapcar
        '(lambda (x)
           (if (= (cdr x) ij)
             (setq l1 (cons (car x) l1))
           )
         )
        set1
      )
      (setq l1 (reverse (wr_sorten l1 car))
            j1 1
      )
      (mapcar
        '(lambda (x)
           (setq j2 (cdr (assoc x set2)))
           (if (= wmode "Tab")
             (progn
               (repeat (- j2 j1)
                 (princ "\t" fs)
               )
               (princ (cdr (assoc 1 (entget x))) fs)
             )
             (progn
               (repeat (- j2 j1 1)
                 (princ " " fs)
               )
               (princ (cdr (assoc 1 (entget x))) fs)
             )
           )
           (setq j1 j2)
         )
        l1
      )
      (princ "\n" fs)
    )
    (close fs)
  )
)

(defun c:wr (/             axis    col     e0             fn             fs             i             ii
             ij             j1             j2             l1             list0   list1   mc             olderr
             oldsnp  oldzin  row     se             set0    set1    set2    ss
             text_name             tmp     wmode   x             y             ym             wr_col
             wr_main wr_m_pt wr_row  wr_sorten             wr_set  na
            )
  (command "color" (getvar "cecolor"))
  (princ "\n选取文本: ")
  (setq se1 (ssget '((0 . "TEXT"))))
  (if se1
    (progn
      (wr_defun)
      (wr_main)
    )
    (princ "\n空选择集。")
  )
  (princ)
)

(princ "\n**Text文本写入文件，自由软件，版本号 0.91,作者: 南京市市政设计研究院 嵇龙。**")
(princ "\n**命令：wr")

(defun c:zc (/ zc:pt1 zc:pt2 zc_sc olderr oldzin newerr)
  (defun newerr        (s)
    (if        (= s "Function cancelled")
      (progn
        (setq *error* olderr)
        (if oldzin
          (setvar "dimzin" oldzin)
        )
      )
    )
    (princ)
  )
  (setq olderr *error*)
  (setq *error* newerr)
  (setq oldzin (getvar "dimzin"))
  (setvar "dimzin" 8)
  (if (not zc_scl)
    (setq zc_scl 1.0)
  )
  (initget "Scale")
  (setq        zc:pt0 (getpoint
                 (strcat "\n比例S(=" (rtos zc_scl) ")/实视图中心点: ")
               )
  )
  (if (= zc:pt0 "Scale")
    (progn
      (initget 6)
      (setq
        zc_sc (getreal (strcat "\n视图比例< " (rtos zc_scl) " >: "))
      )
      (if zc_sc
        (setq zc_scl zc_sc)
      )
      (c:zc)
    )
  )
  (if zc:pt0
    (progn
      (setq zc:y   (/ 188.0 2 zc_scl)          ;188.0为屏幕图形区实际高度（mm）
            zc:x   (* zc:y 1.68)
            zc:pt1 (list (- (car zc:pt0) zc:x) (- (cadr zc:pt0) zc:y) 0.0)
            zc:pt2 (list (+ (car zc:pt0) zc:x) (+ (cadr zc:pt0) zc:y) 0.0)
      )
      (command "zoom" zc:pt1 zc:pt2)
    )
  )
  (setvar "dimzin" oldzin)
  (setq *error* olderr)
  (princ)
)

flychen

不知在哪里设置自动加载

long78

文字对齐的好用，谢谢楼主无私。

lhj743

请问楼主！
要统计钢筋，可是怎么画钢筋来选取啊？
是不是还要配合你的其他画钢筋的程序！
极盼各位知情朋友解答！

li_seagull

楼主可以完善它。做成小集合对有的朋友挺有用的。

又错了

大哥哥，我是新来的，我的级别还不能下载你的东西，你要是方便的话，给我发一个。
liuzhizeng@163.com。
或者是大家哪位方便帮忙发一下，不胜感激！

zengwei104

一下子提供这么多有用的东东，可以大大提高我的效率了

xumaling

新手，不能下载，如果愿意，xumaling@sohu.com。

baichi

试试

yuliutao

不会用啊

zk_hisen

不管怎么说，楼主精神可嘉！谢谢！

midali

是啊
我得爱心比不够了

jjss

楼主可以完善它。做成小集合对有的朋友挺有用的。

ashe

很好的程序~~
写写楼主~~~

jiangen402

是个好东西！在cad里的计算还是很有用！