Number a block attribute in sequence

Plain text, nothing hidden. Copy it into a file named cxattnum.lsp, or download it.

;;; ============================================================================
;;; CXATTNUM - Number a block attribute in sequence
;;; Version 1.0.0
;;; CADXChange LISP tools - https://cadxchange.net/resources/lisp/cxattnum
;;; Tested in: AutoCAD (full version). Other programs that run AutoLISP may work but are not tested.
;;; Copyright (c) CADXChange. Free for personal and commercial use; do not resell or
;;; republish it as a collection. Terms: https://cadxchange.net/legal/lisp-terms
;;; ============================================================================

;; Number the attribute TAG of the block references in NAMES in the order they sit in the drawing.
;; CFG = (start step digits prefix suffix order); ORDER is "Across" (rows from the top, each left to right)
;; or "Down" (columns from the left, each from the top). TOL is how far apart two blocks of one row (column) may be.
;; Blocks without the attribute are skipped and do not use up a number. Returns the next number.
(defun cx:attnum-run (names tag cfg tol / items sorted n)
  (setq items  (mapcar (function (lambda (e) (cons (cx:dxf 10 (entget e)) e))) names)
        sorted (mapcar 'cdr
                       (if (= (nth 5 cfg) "Down")
                         (cx:sort-grid items 0 nil 1 T tol)
                         (cx:sort-grid items 1 T 0 nil tol)))
        n      (car cfg))
  (foreach e sorted
    (if (cx:att-set e tag (strcat (nth 3 cfg) (cx:pad0 n (nth 2 cfg)) (nth 4 cfg)))
      (setq n (+ n (cadr cfg)))))
  n)

;; Two times the average attribute height: a sensible default for how far blocks of one row may differ in Y.
(defun cx:attnum-tol (names tag / sum cnt a)
  (setq sum 0.0 cnt 0)
  (foreach e names
    (if (setq a (cx:att-find e tag))
      (setq sum (+ sum (cx:dxf 40 (entget a))) cnt (1+ cnt))))
  (if (> cnt 0) (* 2.0 (/ sum cnt)) 5.0))

(defun c:CXATTNUM ( / *error* cx:sv ss names tags tag start step digits prefix suffix order tol next)
  (setq *error* cx:err)
  (if (setq ss (cx:pick "\nSelect blocks with attributes: " '((0 . "INSERT") (66 . 1))))
    (progn
      (setq names (cx:ss->list ss)
            tags  (cx:tags names))
      (if (null tags)
        (princ "\nThe selected blocks have no attributes.")
        (progn
          (princ (strcat "\nAttributes in the selection: " (cx:join tags ", ")))
          (setq tag    (cx:ask-str "Attribute to number" (car tags))
                start  (cx:ask-int "Start number" 1)
                step   (cx:ask-int "Step" 1)
                digits (max 1 (cx:ask-int "Minimum digits (3 gives 001)" 1))
                prefix (cx:ask-str "Prefix (- for none)" "")
                suffix (cx:ask-str "Suffix (- for none)" "")
                order  (cx:ask-kw "Order" "Across Down" "Across")
                tol    (cx:ask-real "Blocks within this distance count as one row" (cx:attnum-tol names tag)))
          (cx:start '(("CMDECHO" . 0)))
          (setq next (cx:attnum-run names tag (list start step digits prefix suffix order) tol))
          (princ (strcat "\nNumbered up to " (itoa (- next step)) ". The next number is " (itoa next) "."))
          (cx:end)))))
  (princ))


;;; ---- Shared helpers (used by the command above; identical in every CADXChange tool) ----

(defun cx:dxf (code ed)
  (cdr (assoc code ed)))

;; Merge sort of LST with PRED (a function of two items that is true when the first goes first).
(defun cx:sort (lst pred / half a b out)
  (cond
    ((or (null lst) (null (cdr lst))) lst)
    (T
     (setq half (/ (length lst) 2) a nil b lst)
     (repeat half (setq a (cons (car b) a) b (cdr b)))
     (setq a (cx:sort (reverse a) pred) b (cx:sort b pred) out nil)
     (while (and a b)
       (if (apply pred (list (car b) (car a)))
         (setq out (cons (car b) out) b (cdr b))
         (setq out (cons (car a) out) a (cdr a))))
     (append (reverse out) a b))))

;; Sort ITEMS ((point . data) ...) into rows or columns: first by AXIS1 (0 = X, 1 = Y; DESC1 = T for large to small),
;; items whose AXIS1 values differ by less than TOL stay in one group, and each group is sorted by AXIS2.
(defun cx:sort-grid (items axis1 desc1 axis2 desc2 tol / sorted groups cur ref out)
  (setq sorted (cx:sort items
                 (function (lambda (a b)
                   (if desc1
                     (> (nth axis1 (car a)) (nth axis1 (car b)))
                     (< (nth axis1 (car a)) (nth axis1 (car b))))))))
  (foreach it sorted
    (if (and cur (<= (abs (- (nth axis1 (car it)) ref)) tol))
      (setq cur (cons it cur))
      (progn
        (if cur (setq groups (cons (reverse cur) groups)))
        (setq cur (list it) ref (nth axis1 (car it))))))
  (if cur (setq groups (cons (reverse cur) groups)))
  (foreach g (reverse groups)
    (setq out (append out
                (cx:sort g
                  (function (lambda (a b)
                    (if desc2
                      (> (nth axis2 (car a)) (nth axis2 (car b)))
                      (< (nth axis2 (car a)) (nth axis2 (car b))))))))))
  out)

;; The ATTRIB entities of a block reference, in order.
(defun cx:attribs (ins / e out)
  (setq e (entnext ins))
  (while (and e (= (cx:dxf 0 (entget e)) "ATTRIB"))
    (setq out (cons e out) e (entnext e)))
  (reverse out))

;; The ATTRIB of a block reference with the tag TAG (any case), or nil.
(defun cx:att-find (ins tag / r)
  (foreach a (cx:attribs ins)
    (if (and (not r) (= (strcase (cx:dxf 2 (entget a))) (strcase tag))) (setq r a)))
  r)

;; Replace the text of a TEXT, ATTRIB, ATTDEF or MTEXT.
(defun cx:text-set (ename str / ed out)
  (setq ed (entget ename))
  (if (= (cx:dxf 0 ed) "MTEXT")
    (progn
      ;; MTEXT stores text in 250-character pieces: 3 groups for the first pieces, 1 for the last
      (foreach p ed (if (not (member (car p) '(1 3))) (setq out (cons p out))))
      (setq out (reverse out))
      (while (> (strlen str) 250)
        (setq out (append out (list (cons 3 (substr str 1 250)))) str (substr str 251)))
      (setq ed (append out (list (cons 1 str)))))
    (setq ed (subst (cons 1 str) (assoc 1 ed) ed)))
  (entmod ed)
  (entupd ename)
  T)

;; Set the attribute TAG of a block reference to VALUE; returns T when the block has that attribute.
(defun cx:att-set (ins tag value / a)
  (if (setq a (cx:att-find ins tag))
    (progn (cx:text-set a value) (entupd ins) T)))

;; Integer N as a string padded with zeros to WIDTH characters (the minus sign stays in front).
(defun cx:pad0 (n width / s)
  (setq s (itoa (abs n)))
  (while (< (strlen s) width) (setq s (strcat "0" s)))
  (if (< n 0) (strcat "-" s) s))

;; Close the undo step and put the system variables back.
(defun cx:end ()
  (foreach v cx:sv (setvar (car v) (cdr v)))
  (command "_.UNDO" "_End")
  (setq cx:sv nil)
  (princ))

;; Error handler: restores everything, stays quiet on Esc.
(defun cx:err (msg)
  (if (> (getvar "CMDACTIVE") 0) (command))
  (cx:end)
  (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")))
    (princ (strcat "\nError: " msg)))
  (princ))

;; Use the objects already selected, or ask the user to select; FILTER is an ssget filter list or nil.
(defun cx:pick (msg filter / ss)
  (setq ss (if filter (ssget "_I" filter) (ssget "_I")))
  (if (null ss)
    (progn
      (princ msg)
      (setq ss (if filter (ssget filter) (ssget)))))
  ss)

;; Selection set to a list of entity names.
(defun cx:ss->list (ss / i out)
  (setq i 0)
  (if ss
    (repeat (sslength ss)
      (setq out (cons (ssname ss i) out)
            i   (1+ i))))
  (reverse out))

;; The attribute tags found in a list of block references, each once, in order of appearance.
(defun cx:tags (names / out)
  (foreach e names
    (foreach a (cx:attribs e)
      (if (not (member (strcase (cx:dxf 2 (entget a))) (mapcar 'strcase out)))
        (setq out (append out (list (cx:dxf 2 (entget a))))))))
  out)

(defun cx:join (lst delim / out)
  (setq out "")
  (foreach s lst
    (setq out (if (= out "") s (strcat out delim s))))
  (if lst out ""))

;; Ask for a string (spaces allowed) with a default; "-" means an empty string.
(defun cx:ask-str (msg def / v)
  (setq v (getstring T (strcat "\n" msg " <" def ">: ")))
  (cond ((= v "") def) ((= v "-") "") (T v)))

;; Ask for an integer with a default; returns the default on Enter.
(defun cx:ask-int (msg def / v)
  (setq v (getint (strcat "\n" msg " <" (itoa def) ">: ")))
  (if v v def))

;; Replace every OLD in STR by NEW (case sensitive).
(defun cx:replace (str old new / n out pos)
  (setq n (strlen old) out "" pos 1)
  (if (= n 0)
    str
    (progn
      (while (<= pos (1+ (- (strlen str) n)))
        (if (= (substr str pos n) old)
          (setq out (strcat out new) pos (+ pos n))
          (setq out (strcat out (substr str pos 1)) pos (1+ pos))))
      (strcat out (substr str pos)))))

;; Ask for one of the keywords in BITS ("Yes No"), default DEF; returns the keyword.
(defun cx:ask-kw (msg bits def / v)
  (initget 0 bits)
  (setq v (getkword (strcat "\n" msg " [" (cx:replace bits " " "/") "] <" def ">: ")))
  (if v v def))

;; Real X as text with at most PREC decimals and no trailing zeros ("2.50" -> "2.5", "3.00" -> "3").
(defun cx:num (x prec / s)
  (setq s (rtos x 2 prec))
  (if (wcmatch s "*.*")
    (progn
      (while (= (substr s (strlen s)) "0") (setq s (substr s 1 (1- (strlen s)))))
      (if (= (substr s (strlen s)) ".") (setq s (substr s 1 (1- (strlen s)))))))
  (if (or (= s "-0") (= s "")) "0" s))

(defun cx:ask-real (msg def / v)
  (setq v (getreal (strcat "\n" msg " <" (cx:num def 6) ">: ")))
  (if v v def))

;; Save the system variables in VARS ((name . value) ...), set them, and open one undo step.
;; The caller declares cx:sv as a local so the saved values live exactly as long as the command.
(defun cx:start (vars)
  (setq cx:sv (mapcar (function (lambda (v) (cons (car v) (getvar (car v))))) vars))
  (command "_.UNDO" "_Begin")
  (foreach v vars (setvar (car v) (cdr v)))
  (princ))

(princ "\nCXATTNUM loaded. Type CXATTNUM to start.")
(princ)

More commands: Blocks and attributes

• CXATTFILLFill an attribute in many blocks
• CXATTCOPYCopy attribute values from one block to others
• CXATTVISShow or hide block attributes
• CXBLKCOUNTCount blocks by name
• CXBLKREPLReplace blocks with another block
• CXBLKRENRename blocks in bulk
• CXBLKXPExplode blocks but keep their attribute text
• CXBLKSELSelect blocks by name or attribute value
• CXBLKATInsert a block at many places at once