[LISP程序]：序号球序号重新排序

lsjjm

序号球序号重新排序
功能：用于序号球中的序号重新排序；
      可选上下，左右开始；
      自动提示序号初始值。
[PHP]
(defun c:test (/ ssl ttl)       
  (prompt "\nSelect NumberBall:")
  (setq ss (ssget '((0 . "TEXT"))) n 0)
  (while (< n (sslength ss))
    (setq ssl (cons (ssname ss n) ssl))
    (setq n (1+ n))
  )
  (initget "L R T B")
  (setq        kw (getkword "\nSelect Start End[Left/Right/Top/Bottom]: "))
  (cond
    ((= kw "L")
      (setq ssl (vl-sort ssl '(lambda (p1 p2)(< (car (cdr (assoc 10 (entget p1))))
                                         (car (cdr (assoc 10 (entget p2)))))))))
    ((= kw "R")
      (setq ssl (vl-sort ssl '(lambda (p1 p2)(> (car (cdr (assoc 10 (entget p1))))
                                    (car (cdr (assoc 10 (entget p2)))))))))       
    ((= kw "B")
      (setq ssl (vl-sort ssl '(lambda (p1 p2)(< (cadr (cdr (assoc 10 (entget p1))))
                                    (cadr (cdr (assoc 10 (entget p2)))))))))
    ((= kw "T")
      (setq ssl (vl-sort ssl '(lambda (p1 p2)(> (cadr (cdr (assoc 10 (entget p1))))
                                    (cadr (cdr (assoc 10 (entget p2)))))))))
  )
  (setq ttl (vl-sort ssl '(lambda (p1 p2)(< (atoi (cdr (assoc 1 (entget p1))))
                                    (atoi (cdr (assoc 1 (entget p2))))))))
  (setq ns0 (cdr (assoc 1 (entget (car ttl)))))
  (setq ns (getint (strcat "\nStart Number<" ns0 ">:")))
  (if ns nil (setq ns (atoi ns0)))
  (setq n 0)
  (while (< n (length ssl))
    (setq obj (vlax-ename->vla-object (nth n ssl)))
    (vla-put-textstring obj (itoa (+ ns n)))
    (setq n (1+ n))
  )
)
[/PHP]