[LISP程序]：多功能序号球生成及编辑程序集

lsjjm

多功能序号球生成及编辑程序集(部分子程序前已贴出):
[PHP]
序号球生成程序一:
点击零件上点和序号球所在点, 循环生成由引线,号码和圆组成的序号球. 可选起始号码,字高,引线端部结构. 并具有后序球自动水平或垂直对其前一个序号球.
(defun generatenumball ()
  (setvar "osmode" 0)
  (setvar "orthomode" 0)
  (initget "A D N")
  (setq        kw (getkword "\nSelect Point Style[Arrow/Dot/None]: "))
  (if (null kw)(setq kw "A"))
  (setq ldr (getvar "DIMLDRBLK"))
  (cond
    ((= kw "A")(setvar "DIMLDRBLK" "."))
    ((= kw "D")(setvar "DIMLDRBLK" "dot"))       
    ((= kw "N")(setvar "DIMLDRBLK" "none"))
  )  
  (setq sn (getint (strcat "\nType in Start Number:<1>")))
  (if sn nil (setq sn 1))
  (setq th0 (* 1.5 (getvar "dimscale")(getvar "dimtxt")))
  (setq th (getreal (strcat "\nHeight of Text: <" (rtos th0 2 2) ">")))
  (if th nil (setq th th0))
  (setq  r (* 1.2 th))  
  (setq p0 (getpoint "\nInput point"))
  (while sn
    (if pe (setq pe0 pe))
    (setq pe (getpoint p0 "\nPick End Point"))
    (princ "\nItem Number or Break: n <")
    (princ sn)
    (setq sn0 (getstring ">:"))
    (if pe0
      (if (< (abs (- (car pe)(car pe0)))(abs (- (cadr pe)(cadr pe0))))
        (setq pe (list (car pe0)(cadr pe)))
        (setq pe (list (car pe)(cadr pe0)))
      )
    )
    (command "leader" p0 (polar pe (angle pe p0) r) "" "" "n")
    (vl-cmdf "circle"  pe r)
    (if (= (type inum) 'STR)(setq sn (atoi sn)))
    (vl-cmdf "text" "j" "m" pe th 0 (itoa sn) "")
    (setq p0 (getpoint "\nPick start Point"))
    (setq sn (1+ sn))
  )
)
序号球生成程序二:
批量点击零件上诸点, 点击序号球希望所在直线两端点（水平或垂直） 自动等间隔生成序号球. 可选起始号码,字高,引线端部结构.
(defun batchnumball ( / p pl)
  (setvar "osmode" 0)
  (initget "A D N")
  (setq        kw (getkword "\nSelect Point Style[Arrow/Dot/None]: "))
  (if (null kw)(setq kw "A"))
  (setq ldr (getvar "DIMLDRBLK"))
  (cond
    ((= kw "A")(setvar "DIMLDRBLK" "."))
    ((= kw "D")(setvar "DIMLDRBLK" "dot"))       
    ((= kw "N")(setvar "DIMLDRBLK" "none"))
  )   
  (setq sn (getint (strcat "\nType in Start Number:<1>")))
  (if sn nil (setq sn 1))
  (setq th0 (* 1.5 (getvar "dimscale")(getvar "dimtxt")))
  (setq th (getreal (strcat "\nHeight of Text: <" (rtos th0 2 2) ">")))
  (if th nil (setq th th0))
  (setq  r (* 1.2 th))
  (while (setq p (getpoint "\nPick Point in Part: "))
    (setq pl (cons p pl))
  )
  (setvar "orthomode" 1)
  (setq ps (getpoint "\nPick the First Point: "))
  (setq pe (getpoint ps "\nPick the First Point: "))
  (if (equal (cadr ps)(cadr pe) 0.0001)
    (setq pl (vl-sort pl '(lambda (p1 p2)(< (car p1)(car p2)))))
    (setq pl (vl-sort pl '(lambda (p1 p2)(< (cadr p1)(cadr p2)))))
  )   
  (if (or (> (car ps)(car pe))(> (cadr ps)(cadr pe)))
    (setq pl (reverse pl))
  )      
  (setq l (/ (distance ps pe)(1- (length pl))))
  (setq n 0)
  (while (< n (length pl))
    (vl-cmdf "circle" ps r)
    (vl-cmdf "text" "j" "m" ps th 0 (itoa (1+ n)) "")
    (setq pte (polar ps (angle ps (nth n pl)) r))
    (command "leader" (nth n pl) pte "" "" "n")
    (setq ps (polar ps (angle ps pe) l))
    (setq n (1+ n))
  )
)
鼠标拖动编辑序号球：
框选序号球（单个）依鼠标点击位置整体移动序号球，引线自动伸缩且保持原点不变。
(defun dragnumball (/ leobj liobj)       
  (vl-load-com)
  (setq loop t)
  (setq ss (ssget))
  (setq n 0)
  (while (< n (sslength ss))
    (setq obj (vlax-ename->vla-object (ssname ss n)))
    (setq oname (vla-get-ObjectName obj))
    (cond
      ((= oname "AcDbLeader")
       (setq leobj obj
             p1           (vlax-curve-getstartpoint (ssname ss n))))
      ((= oname "AcDbLine")
       (setq liobj obj
             p1           (vlax-curve-getstartpoint (ssname ss n))
             p2           (vlax-curve-getendpoint (ssname ss n))))
      ((= oname "AcDbCircle")
       (setq ccobj obj
             pc           (cdr (assoc 10 (entget (ssname ss n))))))
      ((= oname "AcDbText") (setq ttobj obj))
    )
    (setq n (1+ n))
  )
  (if liobj
    (if        (< (distance p1 pc) (distance p2 pc))
      (setq p0 p1            p1 p2            p2 p0      )
    )
  )
  (while loop
    (setq p (grread T))
    (if        (= (car p) 3)      (setq loop nil)    )
    (vla-put-center ccobj (vlax-3d-point (cadr p)))
    (vla-put-textalignmentpoint ttobj (vlax-3d-point (cadr p)))
    (setq pc (vlax-safearray->list
               (vlax-variant-value (vla-get-center ccobj))             )
    )
    (setq p2 (polar pc (angle pc p1) (vla-get-radius ccobj)))
    (cond
      (leobj
       (setq sl (vlax-make-safearray vlax-vbdouble '(0 . 5)))
       (setq sa (vlax-safearray-fill sl (append p1 p2)))
       (vla-put-coordinates leobj sa)
       (vla-update leobj)
      )
      (liobj
       (vla-put-startpoint liobj (vlax-3d-point p1))
       (vla-put-endpoint liobj (vlax-3d-point p2))
       (vla-update liobj)
      )
    )
  )
)
批量修改序号球引线端部结构：
(defun headtype ()
  (setq ss (ssget '((0 . "LEADER"))) n 0)
  (setq        at (getint "\nSelect New ArrowHeadType code: "))
  (while (< n (sslength ss))
    (setq obj (vlax-ename->vla-object (ssname ss n)))
    (vla-put-arrowheadtype obj (itoa at))
    (setq n (1+ n))
  )  
)
水平或垂直对齐序号球：
先点击参考点，框选序号球。
(defun alignnumball (/ lst tts ees)       
  (vl-load-com)
  (setvar "osmode" 4)
  (setq pc0 (getpoint "\nPcik Alignment Point:"))
  (prompt "\nSelect NumberBall:")
  (setq ss (ssget) n 0)
  (setq al (getstring "\nSelect Alignment Style[Horizontal/Vertical] "))
  (if (or (null al)(= al ""))(setq al "H"))
  (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 "AcDbLine")
       (ssadd (ssname ss n) ll))
      ((= oname "AcDbCircle")
       (ssadd (ssname ss n) cc))
      ((= oname "AcDbText")
       (ssadd (ssname ss n) tt))
    )
    (setq n (1+ n))
  )
  (if (= (strcase al) "H")      
    (setq cc (acet-ss-sort cc 'getx) ee (acet-ss-sort ee 'getx)
          tt (acet-ss-sort tt 'getx) ll (acet-ss-sort ll 'getx))
    (setq cc (acet-ss-sort cc 'gety) ee (acet-ss-sort ee 'gety)
          tt (acet-ss-sort tt 'gety) ll (acet-ss-sort ll 'gety))
  )
  (setq n 0)
  (while (< n (sslength cc))
    (setq obj (vlax-ename->vla-object (ssname cc n)))
    (setq pc (vtol (vla-get-center obj)))
    (if (= (strcase al) "H")
      (setq pc1 (list (car pc)(cadr pc0)(last pc)))
      (setq pc1 (list (car pc0)(cadr pc)(last pc)))
    )
    (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))
  )
)
(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))))
等间隔重新排列序号球：
框选序号球，提示缺省间隔值，可选间隔，自动依所选序号球趋于水平或垂直排列。
(defun arraynumball ()       
  (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 sortnumball (/ 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]

l1z

多功能序号球生成及编辑程序集(部分子程序前已贴出):

ljs026

太棒了！大大真是厲害！

JH9981

能说明一下吗怎么用?谢谢了。