[编程交流] 是否有编号命令i

;; ============ NumCur.lsp ===============
;;
;;  FUNCTION:
;;  Will sequentially place numerical
;;  text at the end of a leader, upon
;;  mouse click.
;;
;;  SYNTAX: numCur
;;
;;  AUTHOR:
;;  Copyright (c) 2009, Lee McDonnell
;;  (Contact Lee Mac, CADTutor.net)
;;
;;  PLATFORMS:
;;  No Restrictions,
;;  only tested in ACAD 2004.
;;
;;  VERSION:
;;  1.0  ~  05.04.2009
;;
;; =======================================
(defun c:numCur (/ *error* vlst ovar doc spc dVars
          tmpVars cObj tBox GLst mPos cPt
          cDis EnPt ArPt1 ArPt2 AngCor vCol
          Verts VertVar )
 
 (vl-load-com)
 (defun *error* (msg)
   (redraw)
   (if ovar (mapcar 'setvar vlst ovar))
   (if (not (member msg '("Function cancelled" "quit / exit abort")))
     (princ (strcat "\nError: " (strcase msg)))
     (princ "\n<<-- cancelled -->>"))
   (princ))
 (setq vlst '("OSMODE" "CLAYER")
   ovar (mapcar 'getvar vlst))
 (setvar "OSMODE" 0)
 (setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object))
       spc (if (zerop (vla-get-activespace doc))
             (if (= (vla-get-mspace doc) :vlax-true)
               (vla-get-modelspace doc)
               (vla-get-paperspace doc))
             (vla-get-modelspace doc)))
 
 (or (tblsearch "LAYER" "Num-Text")
     (vla-put-color
   (vla-add
     (vla-get-layers doc) "NumText") acYellow))
 (setq dVars '(sNum inNum Pref Suff))
 (mapcar '(lambda (x y) (or (boundp x) (set x y))) dVars '(1 1 "" ""))
 (setq tmpVars (list (getreal (strcat "\nSpecify Starting Number <" (rtos sNum 2 2) ">: "))
             (getreal (strcat "\nSpecify Increment <" (rtos inNum 2 2) ">: "))
             (getstring t (strcat "\nSpecify Prefix <" (if (eq "" Pref) "-None-" Pref) ">: "))
             (getstring t (strcat "\nSpecify Suffix <" (if (eq "" Suff) "-None-" Suff) ">: "))))
 (mapcar '(lambda (x y) (or (or (not x) (eq "" x)) (set y x))) tmpVars dVars)
 (while (and (setq cEnt (car (entsel "\nSelect Curve to Label: ")))
         (member (cdr (assoc 0 (entget cEnt)))
           '("LINE" "POLYLINE" "LWPOLYLINE" "SPLINE" "ARC" "ELLIPSE" "CIRCLE")))
   (vla-EndUndoMark doc)
   (vla-StartUndomark doc)
   (setq cObj (vlax-ename->vla-object cEnt)
     tBox (textbox (list (cons 1 (setq tStr (strcat Pref (rtos sNum 2 0) Suff))))))
   (princ "\nSelect Location for Leader... ")
   (while (= (car (setq GLst (grread T 1))) 5)
     (redraw)
     (if (= (type (setq mPos (cadr GLst))) 'list)
   (progn
     (setq cPt (vlax-curve-getClosestPointto cObj mPos)
       cAng (angle cPt mPos)
       cDis (distance cPt mPos)
       EnPt (polar cPt cAng (/ cDis 1.5))
       ArPt1 (polar cPt (+ cAng (/ pi 12)) (/ cDis 8.0))
       ArPt2 (polar cPt (- cAng (/ pi 12)) (/ cDis 8.0))
       AngCor (fix (abs (* 10.0 (fix (* 18.0 (/ cAng pi)))))))
     (or (and (< AngCor 1.0) (setq vCol 1)) (setq vCol AngCor))
     (grvecs (list vCol cPt EnPt vCol cPt ArPt1 vCol cPt ArPt2)))))
   (princ "\nSelect Leader Size & Angle...")
   (while (= (car (setq GLst (grread T 1))) 5)
     (redraw)
     (if (= (type (setq mPos (cadr GLst))) 'list)
   (progn
     (setq cAng (angle cPt mPos)
       cDis (distance cPt mPos)
       ArPt1 (polar cPt (+ cAng (/ pi 12)) (/ cDis 8.0))
       ArPt2 (polar cPt (- cAng (/ pi 12)) (/ cDis 8.0)))
     (grvecs (list vCol cPt mPos vCol cPt ArPt1 vCol cPt ArPt2)))))
   (setq Verts (apply 'append (list cPt mPos))
     VertVar (vlax-make-variant
           (vlax-safearray-fill
             (vlax-make-safearray
           vlax-vbdouble
           (cons 0 (1- (length Verts))))
             Verts)))
   (vla-addleader spc VertVar
     (vla-addMText spc
   (vlax-3d-Point
     (polar mPos 0 (/ (getvar "TEXTSIZE") 2.0)))
   (- (caadr tBox) (caar tBox)) tStr) acLineWithArrow)
   (redraw)
   (setq sNum (+ sNum inNum)))
 (mapcar 'setvar vlst ovar)
 (redraw)
 (princ))

;; ============ NumCur.lsp ===============
;;
;;  FUNCTION:
;;  Will sequentially place numerical
;;  text at the end of a leader, upon
;;  mouse click.
;;
;;  SYNTAX: numCur
;;
;;  AUTHOR:
;;  Copyright (c) 2009, Lee McDonnell
;;  (Contact Lee Mac, CADTutor.net)
;;
;;  PLATFORMS:
;;  No Restrictions,
;;  only tested in ACAD 2004.
;;
;;  VERSION:
;;  1.0  ~  05.04.2009
;;
;; =======================================
(defun c:numCur (/ *error* vlst ovar doc spc dVars
          tmpVars cObj tBox GLst mPos cPt
          cDis EnPt ArPt1 ArPt2 AngCor vCol
          Verts VertVar )
 
 (vl-load-com)
 (defun *error* (msg)
   (redraw)
   (if ovar (mapcar 'setvar vlst ovar))
   (if (not (member msg '("Function cancelled" "quit / exit abort")))
     (princ (strcat "\nError: " (strcase msg)))
     (princ "\n<<-- cancelled -->>"))
   (princ))
 (setq vlst '("OSMODE" "CLAYER")
   ovar (mapcar 'getvar vlst))
 (setvar "OSMODE" 0)
 (setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object))
       spc (if (zerop (vla-get-activespace doc))
             (if (= (vla-get-mspace doc) :vlax-true)
               (vla-get-modelspace doc)
               (vla-get-paperspace doc))
             (vla-get-modelspace doc)))
 
 (or (tblsearch "LAYER" "Num-Text")
     (vla-put-color
   (vla-add
     (vla-get-layers doc) "NumText") acYellow))
 (setq dVars '(sNum inNum Pref Suff))
 (mapcar '(lambda (x y) (or (boundp x) (set x y))) dVars '(1 1 "" ""))
 (setq tmpVars (list (getreal (strcat "\nSpecify Starting Number <" (rtos sNum 2 2) ">: "))
             (getreal (strcat "\nSpecify Increment <" (rtos inNum 2 2) ">: "))
             (getstring t (strcat "\nSpecify Prefix <" (if (eq "" Pref) "-None-" Pref) ">: "))
             (getstring t (strcat "\nSpecify Suffix <" (if (eq "" Suff) "-None-" Suff) ">: "))))
 (mapcar '(lambda (x y) (or (or (not x) (eq "" x)) (set y x))) tmpVars dVars)
 (while (and (setq cEnt (car (entsel "\nSelect Curve to Label: ")))
         (member (cdr (assoc 0 (entget cEnt)))
           '("LINE" "POLYLINE" "LWPOLYLINE" "SPLINE" "ARC" "ELLIPSE" "CIRCLE")))
   (vla-EndUndoMark doc)
   (vla-StartUndomark doc)
   (setq cObj (vlax-ename->vla-object cEnt)
     tBox (textbox (list (cons 1 (setq tStr (strcat Pref (rtos sNum 2 0) Suff))))))
   (princ "\nSelect Location for Leader... ")
   (while (= (car (setq GLst (grread T 1))) 5)
     (redraw)
     (if (= (type (setq mPos (cadr GLst))) 'list)
   (progn
     (setq cPt (vlax-curve-getClosestPointto cObj mPos)
       cAng (angle cPt mPos)
       cDis (distance cPt mPos)
       EnPt (polar cPt cAng (/ cDis 1.5))
       ArPt1 (polar cPt (+ cAng (/ pi 12)) (/ cDis 8.0))
       ArPt2 (polar cPt (- cAng (/ pi 12)) (/ cDis 8.0))
       AngCor (fix (rem (abs (* 10.0 (fix (* 18.0 (/ cAng pi))))) 255.0)))
     (or (and (< AngCor 1.0) (setq vCol 1)) (setq vCol AngCor))
     (grvecs (list vCol cPt EnPt vCol cPt ArPt1 vCol cPt ArPt2)))))
   (princ "\nSelect Leader Size & Angle...")
   (while (= (car (setq GLst (grread T 1))) 5)
     (redraw)
     (if (= (type (setq mPos (cadr GLst))) 'list)
   (progn
     (setq cAng (angle cPt mPos)
       cDis (distance cPt mPos)
       ArPt1 (polar cPt (+ cAng (/ pi 12)) (/ cDis 8.0))
       ArPt2 (polar cPt (- cAng (/ pi 12)) (/ cDis 8.0)))
     (grvecs (list vCol cPt mPos vCol cPt ArPt1 vCol cPt ArPt2)))))
   (setq Verts (apply 'append (list cPt mPos))
     VertVar (vlax-make-variant
           (vlax-safearray-fill
             (vlax-make-safearray
           vlax-vbdouble
           (cons 0 (1- (length Verts))))
             Verts)))
   (vla-addleader spc VertVar
     (vla-addMText spc
   (vlax-3d-Point
     (polar mPos 0 (/ (getvar "TEXTSIZE") 2.0)))
   (- (caadr tBox) (caar tBox)) tStr) acLineWithArrow)
   (redraw)
   (setq sNum (+ sNum inNum)))
 (mapcar 'setvar vlst ovar)
 (redraw)
 (princ))