Numéroter des textes à la suite

Du texte brut, rien de caché. Copiez-le dans un fichier nommé cxnum.lsp ou téléchargez-le.

;;; ============================================================================
;;; CXNUM - Number texts in sequence
;;; Version 1.0.0
;;; CADXChange LISP tools - https://cadxchange.net/resources/lisp/cxnum
;;; 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
;;; ============================================================================

;; Sorts text objects for numbering: "Across" = rows from top to bottom, each row left to right;
;; "Down" = columns from left to right, each column top to bottom.
(defun cx:num-order (names order / items tol)
  (setq items (mapcar (function (lambda (e) (cons (cx:text-pt (entget e)) e))) names)
        tol   (* 0.6 (/ (apply '+ (mapcar (function (lambda (e) (cx:dxf 40 (entget e)))) names))
                        (length names))))
  (mapcar 'cdr
          (if (= order "Down")
            (cx:sort-grid items 0 nil 1 T tol)
            (cx:sort-grid items 1 T 0 nil tol))))

;; Number the texts in NAMES in the order given. CFG = (start step digits prefix suffix mode order).
;; MODE is "Replace" (the number replaces the text), "Before" or "After" (the number is added to it).
;; Returns the number the next text would get.
(defun cx:num-run (names cfg / n s)
  (setq n (car cfg))
  (foreach e names
    (setq s (strcat (nth 3 cfg) (cx:pad0 n (nth 2 cfg)) (nth 4 cfg)))
    (cx:text-set e (cond ((= (nth 5 cfg) "Replace") s)
                         ((= (nth 5 cfg) "Before") (strcat s " " (cx:text-get e)))
                         (T (strcat (cx:text-get e) " " s))))
    (setq n (+ n (cadr cfg))))
  n)

(defun cx:num-settings (cfg)
  (list (cx:ask-int "Start number" (nth 0 cfg))
        (cx:ask-int "Step" (nth 1 cfg))
        (max 1 (cx:ask-int "Minimum digits (3 gives 001)" (nth 2 cfg)))
        (cx:ask-str "Prefix (- for none)" (nth 3 cfg))
        (cx:ask-str "Suffix (- for none)" (nth 4 cfg))
        (cx:ask-kw "Put the number" "Replace Before After" (nth 5 cfg))
        (cx:ask-kw "Numbering order for a selection" "Across Down" (nth 6 cfg))))

(defun c:CXNUM ( / *error* cx:sv cfg act ss names r e n)
  (setq *error* cx:err)
  (setq cfg (if *cx-num* *cx-num* (list 1 1 1 "" "" "Replace" "Across")))
  (setq act "Settings")
  (while (= act "Settings")
    (princ (strcat "\nNext number " (itoa (car cfg)) ", step " (itoa (cadr cfg))
                   ", number " (nth 5 cfg) ", order " (nth 6 cfg)))
    (setq act (cx:ask-kw "Number text" "Settings Select Click" "Select"))
    (if (= act "Settings") (setq cfg (cx:num-settings cfg))))
  (cx:start '(("CMDECHO" . 0)))
  (cond
    ((= act "Click")
     (setq n 0)
     (while (setq r (entsel "\nClick a text (Enter to finish): "))
       (setq e (car r))
       (if (member (cx:dxf 0 (entget e)) '("TEXT" "MTEXT"))
         (setq cfg (cons (cx:num-run (list e) cfg) (cdr cfg))
               n   (1+ n))
         (princ "\nThat is not a text."))))
    (T
     (if (setq ss (cx:pick "\nSelect the texts to number: " '((0 . "TEXT,MTEXT"))))
       (setq names (cx:num-order (cx:ss->list ss) (nth 6 cfg))
             n     (length names)
             cfg   (cons (cx:num-run names cfg) (cdr cfg))))))
  (setq *cx-num* cfg)
  (if (and n (> n 0))
    (princ (strcat "\n" (itoa n) " text(s) numbered. The next number is " (itoa (car cfg)) ".")))
  (cx:end))


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

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

;; The point a TEXT, MTEXT or ATTRIB sits at (the alignment point when it is aligned).
(defun cx:text-pt (ed)
  (if (and (member (cx:dxf 0 ed) '("TEXT" "ATTRIB" "ATTDEF"))
           (or (/= 0 (cx:dxf 72 ed)) (/= 0 (cx:dxf 73 ed)))
           (cx:dxf 11 ed))
    (cx:dxf 11 ed)
    (cx:dxf 10 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)

;; 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))

;; 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)

;; The text of a TEXT, ATTRIB, ATTDEF or MTEXT (MTEXT keeps its codes).
(defun cx:text-get (ename / ed s)
  (setq ed (entget ename))
  (if (= (cx:dxf 0 ed) "MTEXT")
    (progn
      (setq s "")
      (foreach p ed (if (= (car p) 3) (setq s (strcat s (cdr p)))))
      (strcat s (cx:dxf 1 ed)))
    (cx:dxf 1 ed)))

;; 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))

;; 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)))

;; 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))

;; 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))

;; 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))

;; 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))

(princ "\nCXNUM loaded. Type CXNUM to start.")
(princ)

Autres commandes : Texte

• CXTXTADDAjouter un préfixe ou un suffixe à de nombreux textes
• CXTXTCUTCouper des caractères au début ou à la fin des textes
• CXTXTCASEChanger la casse de nombreux textes
• CXTXTREPLRechercher et remplacer dans de nombreux textes
• CXTXTCLEANNettoyer les espaces et la mise en forme des textes
• CXT2MFusionner des textes monolignes en un texte multiligne
• CXM2TÉclater un texte multiligne en textes monolignes
• CXTXTALIGNAligner des textes sur un texte de référence
• CXTXTSTYLEChanger le style et la hauteur de nombreux textes
• CXTXTCOUNTCompter les textes identiques
• CXTXTSUMAdditionner les nombres contenus dans des textes