;;; --------------------------------------------------------------------------- ;;; TagWidth.lsp ;;; code compiled by YZ August 2026 ;;; --------------------------------------------------------------------------- ;;; SQUEEZE AND STRETCH TEXT AND ATTRIBUTES ;;; ;;; PURPOSE ;;; Adjusts the width factor of text and attributes - the amount each ;;; character is condensed or expanded without changing its height. This is ;;; what you reach for when a room name will not fit its room, a title will ;;; not fit its box, or a schedule column is a whisker too narrow. ;;; ;;; Select what you want, then squeeze or stretch it a step at a time and ;;; watch it change. Keep going until it fits, then press Enter. ;;; ;;; WIDTH FACTOR ;;; 1.0 is the font as drawn. Below 1.0 the characters narrow, above 1.0 they ;;; widen. Heights and line spacing are untouched, which is why this is the ;;; right tool for fitting text and scaling is the wrong one. ;;; ;;; Below about 0.7 most fonts start to look pinched, and below 0.5 they ;;; become hard to read at plot size. The routine will let you go there, but ;;; it says so as you pass. ;;; ;;; Note this works on TEXT and ATTRIBUTE objects, which carry a width factor ;;; in the object itself. MTEXT has no such property - its width is set by ;;; the column width and the style - so MTEXT is reported and skipped rather ;;; than silently ignored. ;;; ;;; WHAT WAS FIXED ;;; - The increment variable and the saved error handler were both global, ;;; despite a careful list of locals immediately above them. ;;; - It read group 41 without checking the object had one. Picking anything ;;; that was not text - a line, a block, an MTEXT - reached (+ nil incr) ;;; and stopped with a bad argument type. ;;; - It stopped on the first object that would go to zero width, using an ;;; ALERT box that had to be dismissed before anything else could happen. ;;; A floor is applied instead, and the run continues. ;;; - It worked one object per pick. A whole selection can be adjusted ;;; together now, which is the usual case - a column of schedule text is ;;; rarely too wide on its own. ;;; - There was no undo group, so backing out an adjustment meant pressing U ;;; once per nudge. ;;; ;;; TAGWIDTH - squeeze or stretch text and attributes to fit ;;; --------------------------------------------------------------------------- (setq TagWidth:FLOOR 0.05 ; never go to zero - the text would vanish TagWidth:STEP 0.05) ; default nudge ;;; --------------------------------------------------------------------------- ;;; SUPPORT ;;; --------------------------------------------------------------------------- ;;; Apply a width factor to one object, clamped so it can never reach zero. ;;; Returns the width actually set, or nil if the object has no width factor. (defun TagWidth:Set ( ent w / data ) (setq data (entget ent)) (if (assoc 41 data) (progn (setq w (max TagWidth:FLOOR w)) (entmod (subst (cons 41 w) (assoc 41 data) data)) (entupd ent) w) ) ) (defun TagWidth:Get ( ent ) (cdr (assoc 41 (entget ent)))) ;;; Gather the text and attributes from a selection, reporting anything that ;;; cannot carry a width factor rather than dropping it in silence. (defun TagWidth:Collect ( ss / i ent data kind out mtext other ) (setq i 0 out nil mtext 0 other 0) (while (< i (sslength ss)) (setq ent (ssname ss i) data (entget ent) kind (cdr (assoc 0 data))) (cond ((member kind '("TEXT" "ATTRIB" "ATTDEF")) (if (assoc 41 data) (setq out (cons ent out)) (setq other (1+ other)))) ((= kind "MTEXT") (setq mtext (1+ mtext))) ((= kind "INSERT") ;; A block was picked rather than an attribute inside it. Take the ;; attributes it carries - almost always what was meant. (setq ent (entnext ent)) (while (and ent (= "ATTRIB" (cdr (assoc 0 (entget ent))))) (if (assoc 41 (entget ent)) (setq out (cons ent out))) (setq ent (entnext ent)))) (t (setq other (1+ other)))) (setq i (1+ i))) (if (> mtext 0) (princ (strcat "\n " (itoa mtext) " MTEXT object" (if (= mtext 1) "" "s") " skipped - MTEXT has no width factor of its own."))) (if (> other 0) (princ (strcat "\n " (itoa other) " other object" (if (= other 1) "" "s") " skipped."))) (reverse out) ) ;;; --------------------------------------------------------------------------- ;;; MAIN COMMAND ;;; --------------------------------------------------------------------------- (defun c:TAGWIDTH ( / *error* vars vals ss ents orig step done v w lo hi warned ) (setq vars '("CMDECHO") vals (mapcar 'getvar vars)) (defun TagWidth:Restore ( ) (mapcar 'setvar vars vals) (while (= 8 (logand 8 (getvar 'undoctl))) (command "_.UNDO" "_End")) (vl-catch-all-apply '(lambda ( ) (*pop-error-mode*)) '()) (princ) ) (defun *error* ( msg ) ;; Put every width back the way it was found. Half an adjustment is ;; worse than none, and the originals are all recorded. (if orig (foreach pair orig (vl-catch-all-apply '(lambda ( ) (TagWidth:Set (car pair) (cdr pair))) '()))) (TagWidth:Restore) (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*"))) (princ (strcat "\n** TAGWIDTH error: " msg " **"))) (princ) ) (setvar "CMDECHO" 0) ;; AutoCAD 2015 and later refuse (command) inside an *error* handler unless ;; the routine says up front that it will use one. (vl-catch-all-apply '(lambda ( ) (*push-error-using-command*)) '()) (command "_.UNDO" "_Begin") (princ "\nSelect the text or attributes to squeeze or stretch.") (setq ss (ssget)) (if (null ss) (princ "\nNothing selected.") (progn (setq ents (TagWidth:Collect ss)) (if (null ents) (princ "\nNothing in that selection carries a width factor.") (progn ;; Remember every starting width, both to report the range ;; and so the error handler can put things back. (setq orig (mapcar '(lambda ( e ) (cons e (TagWidth:Get e))) ents) lo (cdr (car orig)) hi lo) (foreach pair orig (setq lo (min lo (cdr pair)) hi (max hi (cdr pair)))) (princ (strcat "\n" (itoa (length ents)) " object" (if (= 1 (length ents)) "" "s") " selected, width factor " (if (equal lo hi 1e-8) (rtos lo 2 3) (strcat (rtos lo 2 3) " to " (rtos hi 2 3))) ".")) (setq step TagWidth:STEP done nil warned nil) (while (not done) (initget "Narrower Wider Set Reset Step") (setq v (getkword (strcat "\n[Narrower/Wider/Set/Reset/Step] step " (rtos step 2 3) " : "))) (cond ((null v) (setq done t)) ((= v "Step") (initget 6) (setq w (getreal (strcat "\n Step size <" (rtos step 2 3) ">: "))) (if w (setq step w))) ((= v "Set") (initget 6) (setq w (getreal "\n Width factor to set: ")) (if w (foreach e ents (TagWidth:Set e w)))) ((= v "Reset") (foreach e ents (TagWidth:Set e 1.0))) (t ;; Each object moves by the step from its OWN ;; current width, so a mixed selection keeps its ;; relative differences. (foreach e ents (TagWidth:Set e (+ (TagWidth:Get e) (if (= v "Wider") step (- step))))))) (if (not done) (progn (setq lo (TagWidth:Get (car ents)) hi lo) (foreach e ents (setq w (TagWidth:Get e) lo (min lo w) hi (max hi w))) (princ (strcat " now " (if (equal lo hi 1e-8) (rtos lo 2 3) (strcat (rtos lo 2 3) " to " (rtos hi 2 3))))) ;; Say it once, not on every nudge. (if (and (< lo 0.7) (not warned)) (progn (princ " - getting pinched") (setq warned t))) (if (>= lo 0.7) (setq warned nil))))) (princ (strcat "\n" (itoa (length ents)) " object" (if (= 1 (length ents)) "" "s") " adjusted.")) ;; Accepted, so there is nothing for the error handler to ;; put back. (setq orig nil) ) ) ) ) (TagWidth:Restore) (princ) ) (princ)