[LISP程序]：等间隔重新排列序号球

lsjjm

等间隔重新排列序号球
功能：自动按水平或垂直方向等间隔重新排列序号球；
      可提示（缺省值）原来区域内等分间隔。
[PHP]
(defun c:test ()       
  (vl-load-com)
  (prompt "\nSelect NumberBall:")
  (setq ss (ssget) n 0)
  (setq cc (ssadd) tt (ssadd) ee (ssadd) ll (ssadd))
  (while (< n (sslength ss))
    (setq obj (vlax-ename->vla-object (ssname ss n)))
    (setq oname (vla-get-ObjectName obj))
    (cond
      ((= oname "AcDbLeader")
       (ssadd (ssname ss n) ee))
      ((= oname "AcDbCircle")
       (ssadd (ssname ss n) cc))
      ((= oname "AcDbText")
       (ssadd (ssname ss n) tt))
    )
    (setq n (1+ n))
  )
  (setq bb (acet-geom-ss-extents cc t))
  (setq x (- (car (cadr bb))(car (car bb))))
  (setq y (- (cadr (cadr bb))(cadr (car bb))))
  (setq r (cdr (assoc 40 (entget (ssname cc 0)))))
  (if (> x y)      
    (setq cc (acet-ss-sort cc 'getx) ee (acet-ss-sort ee 'getx)
           d0 (/ (- x r r )(1- (sslength cc))))
    (setq cc (acet-ss-sort cc 'gety) ee (acet-ss-sort ee 'gety)
           d0 (/ (- y r r )(1- (sslength cc))))
  )
  (setq d (getdist (strcat "\New Gap <" (rtos d0 2 2) "> :")))
  (if (or (null d)(= d ""))(setq d d0))
  (setq obj (vlax-ename->vla-object (ssname cc 0)))
  (setq pc0 (vtol (vla-get-center obj)))
  (setq n 1)
  (while (< n (sslength cc))
    (setq obj (vlax-ename->vla-object (ssname cc n)))
    (setq pc (vtol (vla-get-center obj)))
    (if (> x y)
      (setq pc1 (list (+ (car pc0) d)(cadr pc)(last pc)) pc0 pc1)
      (setq pc1 (list (car pc)(+ (cadr pc0) d)(last pc)) pc0 pc1)
    )
    (vla-put-center obj (vlax-3d-point pc1))
    (vla-put-textalignmentpoint (vlax-ename->vla-object (ssname tt n))(vlax-3d-point pc1))
    (setq p1 (vlax-curve-getstartpoint (vlax-ename->vla-object (ssname ee n))))
    (setq p2 (polar pc1 (angle pc1 p1)(vla-get-radius obj)))
    (setq sl (vlax-make-safearray vlax-vbdouble '(0 . 5)))
       (setq sa (vlax-safearray-fill sl (append p1 p2)))
       (vla-put-coordinates (vlax-ename->vla-object (ssname ee n)) sa)
       (vla-update (vlax-ename->vla-object (ssname ee n)))
    (setq n (1+ n))
  )
  (setvar "osmode" 37)
)
(defun vtol (v)(vlax-safearray->list (vlax-variant-value v)))
(defun getx (ent)(car (cdr (assoc 10 ent))))
(defun gety (ent)(cadr (cdr (assoc 10 ent))))
[/PHP]

xyp1964

NumberBall：
给个说明或操作示意！

lsjjm

加载程序并运行，框选序号球--由圆，数字文本和引线组成。
回应提示，即可。

自由的鱼

确实是比较方便，在注记建筑物栋号时很方便！

hjqpdga

有没有更复杂的

jx2008

以上代码为完整代码，在
http://rss20.gnway.net/html/7/292408.htm#program528337089
的代码比较全，序号球的程序集，但是1楼的代吗不全，要输入验证码才能看全文，但是那个网站的验证码是根本无法显示的。所以是不可能得到完整的代码，1楼楼主很好，把完整的代码贴了出来，辛苦了！支持！

swhlzl

2004下出现错误，选择序号球后，会车出现