[编程申请]：能否将附件中的zbh.lsp完善，能一次完成预应力管桩的编号。

ouking1977

偶在别人处得到的lsp，但在autocad中加载后发现不能用。
主要是用于预应力管桩的编号，筛选框选中所有的circle，然后在圆心上写1,2,3,4......

它山之石

　　程序的问题出在语句(command "text"....中，一个是没定义字体，另外就是没有定义文字高度所需的参数。修改后可以运行。截图如下：
[php]

(defun c:zbh (/ I J N PT S SS SS1 X ZBL BL)
  (setvar "cmdecho" 0)
  (setvar "osmode" 0)
  (princ "\nSelect circle to sort:")
  (setq ss (ssget))
  (setq x (getint (strcat "\nEnter start num: < 1 > : ")))
  (if x
    (setq j x)
    (setq j 1)
  ) ;_ 结束if
  (setq        n   (sslength ss)
        i   0
        ss1 (ssadd)
  ) ;_ 结束setq
  (repeat n
    (setq s (ssname ss i)
          i (1+ i)
    ) ;_ 结束setq
    (setq x (entget s))
    (if        (= (cdr (assoc 0 x)) "CIRCLE")
      (ssadd s ss1)
    ) ;_ 结束if
  ) ;_ 结束repeat
  (setq        ss  ss1
        ss1 nil
  ) ;_ 结束setq
  (setq        n   (sslength ss)
        i   0
        zbl '()
  ) ;_ 结束setq
  (repeat n
    (setq s (ssname ss i)
          i (1+ i)
    ) ;_ 结束setq
    (setq x (entget s))
    (setq pt (cdr (assoc 10 x)))
    (setq zbl (append zbl (list pt)))
  ) ;_ 结束repeat
  (setq x (xiao zbl))
  (setq i 1)
  (repeat n
    (setq pt (nth (1- i) x))
;;;以下是俺为了让程序正确运行而添加的
    (if        (or (= nil (tblsearch "style" "RS"))
            (/= (cdr (assoc 40 (tblsearch "style" "RS"))) 0)
        ) ;_ 结束or
      (command "STYLE" "RS" "romans,HZTXT" "0" ".8" "0"        "n" "n"        "n") ;_ 结束command
    ) ;_ 结束if
    (setq bl 100)
;;;添加结束
    (command "text"
             "S"
             "Rs"
             "J"
             "mc"
             pt
             (* 2.2 bl)
             0.0
             (itoa (+ (1- i) j))
    ) ;_ 结束command
    (setq i (1+ i))
  ) ;_ 结束repeat
  (princ)
) ;_ 结束defun

(defun xiao (ff / F F1 F2 FF1 I M N X1 X2 Y1 Y2)
  (setq        n (1- (length ff))
        m n
  ) ;_ 结束setq
  (repeat m
    (setq f1  (car ff)
          i   1
          ff1 '()
    ) ;_ 结束setq
    (repeat n
      (setq x1 (car f1)
            y1 (cadr f1)
      ) ;_ 结束setq
      (setq f2 (nth i ff))
      (setq x2 (car f2)
            y2 (cadr f2)
      ) ;_ 结束setq
      (if (> y1 y2)
        (setq f         f1
              f1 f2
              f2 f
        ) ;_ 结束setq
      ) ;_ 结束if
      (setq ff1 (append ff1 (list f1)))
      (setq i  (1+ i)
            f1 f2
      ) ;_ 结束setq
    ) ;_ 结束repeat
    (setq ff1 (append ff1 (list f1)))
    (repeat (- m n)
      (setq f2 (nth i ff))
      (setq ff1 (append ff1 (list f2)))
      (setq i (1+ i))
    ) ;_ 结束repeat
    (setq n (1- n))
    (setq ff ff1)
  ) ;_ 结束repeat
  (setq n m)
  (repeat m
    (setq f1  (car ff)
          i   1
          ff1 '()
    ) ;_ 结束setq
    (repeat n
      (setq x1 (car f1)
            y1 (cadr f1)
      ) ;_ 结束setq
      (setq f2 (nth i ff))
      (setq x2 (car f2)
            y2 (cadr f2)
      ) ;_ 结束setq
      (if (and (< (abs (- y1 y2)) 0.1) (> x1 x2))
        (setq f         f1
              f1 f2
              f2 f
        ) ;_ 结束setq
      ) ;_ 结束if
      (setq ff1 (append ff1 (list f1)))
      (setq i  (1+ i)
            f1 f2
      ) ;_ 结束setq
    ) ;_ 结束repeat
    (setq ff1 (append ff1 (list f1)))
    (repeat (- m n)
      (setq f2 (nth i ff))
      (setq ff1 (append ff1 (list f2)))
      (setq i (1+ i))
    ) ;_ 结束repeat
    (setq n (1- n))
    (setq ff ff1)
  ) ;_ 结束repeat
) ;_ 结束defun

[/php]

xyp1964

改了改，试试：
[php](load "xyp_lib");加载通用函数
;|
如果已经下载xyp_lib并放到搜索路径下可以不再下载!
利用以下任何一种方式即可加载和运行通用函数内的所有子程序：
1.在acad.lsp中增加(load"xyp_lib")
2.在每个程序内增加(load"xyp_lib")
3.在command下，输入(load"xyp_lib")
4.在菜单.mnl中增加(load"xyp_lib")
通用函数下载地址：http://www.xdcad.net/forum/showthread.php?s=&threadid=325268
|;

(defun c:test ()
  (cmdla0)
  (jzhz)
  (SETBL)
  (princ "\n选择圆 : ")
  (setq        ss  (ssget '((0 . "CIRCLE")))
        no1 (ureal 1 "" "\n起始编号" 1)
        i   -1
        n   no1
        th  (* SC 300)
  )
  (mkla"管桩编号"4)
  (while (setq s1 (ssname ss (setq i (1+ i))))
    (setq pt (dxf 10 (entget s1)))
    (command "text" "j" "mc" pt th "0" (RTOS n 2 0))
    (setq n (1+ n))
  )
  (cmdla1)
)[/php]
示意：

ouking1977

谢谢了，的确能用了，而且公司有个同事提出在前面加No.的前缀，我试着做，也做出来了。