Updates to a Text Box size LISP - request

[stuie444]

I frequently get poorly executed drawings from engineers and newer drafters - and one of the items we clean up is to shrink the text box on MText items to it's proper minimum size, mainly for masking  (just like when you double-click the double arrows on the ruler of the mtext editor).  This code from Autocadtips1.com shows how it works, and it has served us perfectly in the past (enabled us to correct many mtext entites at the same time, rather than editing and double-clicking the arrows 1 by 1).

We haven't needed it in a while, but boy oh boy I just got a drawing from India or something with hundreds of mtext with text boxes all over the place.  However, this routine doesn't seem to work with 2023, and simply returns "nil"?

Could one of you LISP wizards review this to see if a simple code update will get this working again on newer versions of Acad?  Or is this method simply defunct now?

Apologies if this has been asked before, I tried to do a forum search but didn't find this exact topic.

 

(defun mip-mtext-wrap-BB (en / el SetHandles CheckHandles sclst)
 
(vl-load-com)
 
;;; Argument: the ename of an mtext
 
;;; Shrinkwrap the bounding box of selected MText objects
 
;;; http://discussion.autodesk.com/forums/message.jspa?messageID=5734567
 
;;; ShrinkwrapMText v2a.lsp - Joe Burke - 10/13/2007 - Version 2a
 
;;;;;http://discussion.autodesk.com/forums/thread.jspa?threadID=448625
 
;;;; USE:
 
;;; (mip-mtext-wrap-BB (car(entsel)))
 
;;; !!!! AutoCAD 2010 2011 2012
 
;;; http://forums.autodesk.com/t5/Visual-LISP-AutoLISP-and-General/MTEXT-Column-property/m-p/2690952
 
;;;Need to change the column type from dynamic to not add the dxf group of 75 with 0
 
;;; http://www.theswamp.org/index.php?topic=28243.0
 
(defun GetAnnoScales (e / dict lst rewind res)
 
;;; Argument: the ename of an annotative object.
 
;;; Returns the annotative scales associated with the
 
;;; ename as a list of strings.
 
;;; Example: ("1:1" "1:16" "1:20" "1:30")
 
;;; Returns nil if the ename is not annotative.
 
;;; Can be used to test whether ename is annotative or not.
 
;;; Works with annotative objects: text, mtext, leader, mleader,
 
;;; dimension, block reference, tolerance and attribute.
 
;;; Based on code by Ian Bryant.
 
(if
 
(and
 
e
 
(setq dict (cdr (assoc 360 (entget e))))
 
(setq lst (dictsearch dict "AcDbContextDataManager"))
 
(setq lst
 
(dictsearch (cdr (assoc -1 lst)) "ACDB_ANNOTATIONSCALES")
 
) ;_ end of setq
 
(setq dict (cdr (assoc -1 lst)))
 
) ;_ end of and
 
(progn
 
(setq rewind t)
 
(while (setq lst (dictnext dict rewind))
 
(setq e (cdr (assoc 340 lst))
 
res (cons (cdr (assoc 300 (entget e))) res)
 
rewind nil
 
) ;_ end of setq
 
) ;_ end of while
 
) ;_ end of progn
 
) ;_ end of if
 
(reverse res)
 
) ;end
 
(defun CheckHandles (e / dict lst rewind nlst d42 d43 n p ptlst)
 
;;; Argument: the ename of annotative mtext object.
 
;;; Returns T if the object has only one scale or
 
;;; the handles for all scales are proportionally the
 
;;; same and all scales use the same insertion point.
 
(if
 
(and
 
e
 
(setq dict (cdr (assoc 360 (entget e))))
 
(setq lst (dictsearch dict "AcDbContextDataManager"))
 
(setq lst
 
(dictsearch (cdr (assoc -1 lst)) "ACDB_ANNOTATIONSCALES")
 
) ;_ end of setq
 
(setq dict (cdr (assoc -1 lst)))
 
) ;_ end of and
 
(progn
 
(setq rewind t)
 
(while (setq lst (dictnext dict rewind))
 
(setq nlst (cons lst nlst)
 
rewind nil
 
) ;_ end of setq
 
) ;_ end of while
 
(cond
 
((= 1 (length nlst)))
 
(t
 
;; lst is nil so reuse it.
 
(foreach x nlst
 
;Horizontal width. Can be zero, a null text string.
 
(setq d42 (cdr (assoc 42 x))
 
;Vertical height cannot be zero so a divide
 
;by zero error can't happen.
 
d43 (cdr (assoc 43 x))
 
n (/ d42 d43)
 
lst (cons n lst)
 
;Insertion point
 
p (cdr (assoc 11 x))
 
ptlst (cons p ptlst)
 
) ;_ end of setq
 
) ;_ end of foreach
 
(and
 
(vl-every '(lambda (x) (equal n x 1e-4)) lst)
 
(vl-every '(lambda (x) (equal p x 1e-4)) ptlst)
 
) ;_ end of and
 
)
 
) ;_ end of cond
 
) ;_ end of progn
 
) ;_ end of if
 
) ;end
 
(defun SetHandles (lst / oldlst charwidth ht pat)
 
;;; ;Argument: an entget list.
 
;;; ;Code 42 is the smallest width of the handles.
 
;;; ;If 41 is larger than 42 then the handles can be shrunk
 
;;; ;horizontally given a single line mtext object.
 
;;;
 
;;; ;Code 46 is the current height of the handles in 2007/2008.
 
;;; ;Substitute the actual height from the code 43 value.
 
;;;
 
;;; ;Used to determine number of objects modified.
 
(setq lst (entget (cdr(assoc -1 lst)) '("ACAD")))
 
;;; (setq oldlst lst)
 
(setq charwidth (* (cdr (assoc 42 lst)) 1.05) ;_1.035
 
ht (cdr (assoc 43 lst))
 
lst (subst (cons 41 charwidth) (assoc 41 lst) lst)
 
lst (subst (cons 46 ht) (assoc 46 lst) lst)
 
lst (if (assoc 75 lst) ;;; 75 - òèï êîëîíîê
 
(subst (cons 75 0) (assoc 75 0) lst)
 
(append lst (list(cons 75 0)))
 
)
 
) ;_ end of setq
 
;;;Code 46 is the current height of the handles in 2007/2008.
 
;;;Substitute the actual height from the code 43 value.
 
(if (and
 
(setq pat (assoc -3 lst))
 
(eq "ACAD" (caadr pat))
 
) ;_ end of and
 
(progn
 
(if (assoc 46 lst)
 
;;;Code 46 is the current height of the handles in 2007/2008.
 
;;; Remove extended data regarding height if found.
 
(setq pat '(-3 ("ACAD")))
 
(progn
 
(setq pat
 
(cons -3
 
(list (subst (cons 1040 ht)
 
(assoc 1040 (cdadr pat))
 
(cadr pat)
 
) ;_ end of subst
 
) ;_ end of list
 
) ;_ end of cons
 
) ;_ end of setq
 
) ;_ end of progn
 
) ;_ end of if
 
(setq lst (subst pat (assoc -3 lst) lst))
 
)
 
) ;_ end of if
 
(setq lst (entmod lst))
 
) ;end SetHandles
 
(if (= (cdr (assoc 0 (setq EL (entget en '("*"))))) "MTEXT")
 
(progn
 
(cond
 
((and
 
(setq sclst (GetAnnoScales en))
 
(CheckHandles en)
 
) ;_ end of and
 
(vl-cmdf "._chprop" en "" "_Annotative" "_No" "")
 
;(SetHandles (entget ename))
 
(SetHandles el)
 
(vl-cmdf "._chprop" en "" "_Annotative" "_Yes" "")
 
(foreach x sclst
 
(vl-cmdf "._objectscale" en "" "_Add" x "")
 
) ;_ end of foreach
 
)
 
((not (GetAnnoScales en))
 
(SetHandles el)
 
)
 
(t nil)
 
) ;_ end of cond
 
) ;_ end of progn
 
) ;_ end of if
 
) ;_ end of defun
 
(defun C:TxtBoxWidth (/ ss i)
 
(and (setq ss (ssget "_:L" '((0 . "MTEXT"))))
 
(repeat (setq i (sslength ss))
 
(mip-mtext-wrap-BB (ssname ss (setq i (1- i))))
 
)
 
(setq ss nil)
 
)
 
)

 

[Steven P]

Without going through your code, this is taken from a question this week, the second part was asking exactly the same thing. Link is in the code below. Works for me in reasonable quick testing and checking.

 

;;Text Adjust Box
(defun c:TxtAdjBox ( / thisdrawing MySS SSCount MyEnt MyEntGet MyTextCoords MyTextWdth MyTextHeight Mytext )
;;Taken from https://www.cadtutor.net/forum/topic/79213-autolisp-for-removing-all-linebreaks-and-leave-selection-on/
;;Sub Functions:
;;Starting with LM: Refer to Lee Macs website
  ;; From Box Text LISP
  ;; Text Box  -  gile / Lee Mac
  ;; Returns an OCS point list describing a rectangular frame surrounding
  ;; the supplied text or mtext entity with optional offset
  ;; enx - [lst] Text or MText DXF data list
  ;; off - [rea] offset (may be zero)
  (defun text-box-off ( enx off / bpt hgt jus lst ocs org rot wid )
    ;;; VXV Returns the dot product of 2 vectors
    (defun vxv (v1 v2) (apply '+ (mapcar '* v1 v2)) )
    ;; MXV Apply a transformation matrix to a vector -Vladimir Nesterovsky-
    (defun mxv (m v) (mapcar '(lambda (r) (vxv r v)) m) )
    (cond
        (   (= "TEXT" (cdr (assoc 00 enx)))
            (setq bpt (cdr (assoc 10 enx))
                  rot (cdr (assoc 50 enx))
                  lst (textbox enx)
                  lst
                (list
                    (list (- (caar  lst) off) (- (cadar  lst) off)) (list (+ (caadr lst) off) (- (cadar  lst) off))
                    (list (+ (caadr lst) off) (+ (cadadr lst) off)) (list (- (caar  lst) off) (+ (cadadr lst) off))
                )
            )
        )
        (   (= "MTEXT" (cdr (assoc 00 enx)))
            (setq ocs  (cdr (assoc 210 enx))
                  bpt  (trans (cdr (assoc 10 enx)) 0 ocs)
                  rot  (angle '(0.0 0.0) (trans (cdr (assoc 11 enx)) 0 ocs))
                  wid  (cdr (assoc 42 enx))
                  hgt  (cdr (assoc 43 enx))
                  jus  (cdr (assoc 71 enx))
                  org  (list (cond ((member jus '(2 5 8)) (/ wid -2.0)) ((member jus '(3 6 9)) (- wid))      (0.0))
                             (cond ((member jus '(1 2 3)) (- hgt))      ((member jus '(4 5 6)) (/ hgt -2.0)) (0.0))
                       )
                  lst
                (list
                    (list (- (car org) off)     (- (cadr org) off))     (list (+ (car org) wid off) (- (cadr org) off))
                    (list (+ (car org) wid off) (+ (cadr org) hgt off)) (list (- (car org) off)     (+ (cadr org) hgt off))
                )
            )
        )
    )
    (if lst
        (   (lambda ( m ) (mapcar '(lambda ( p ) (mapcar '+ (mxv m p) bpt)) lst))
            (list
                (list (cos rot) (sin (- rot)) 0.0)
                (list (sin rot) (cos rot)     0.0)
               '(0.0 0.0 1.0)
            )
        )
    )
  )


  (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object)))
  (princ "\nSelect MText")                   ;; Note in command line "Select text"
  (setq MySS (ssget '((0 . "MTEXT"))))       ;; Select objects with a selection set, filtered to 'MTEXT' entity type
  (setq SSCount 0)                           ;; Just a counter set to 0
  (while (< SSCount (sslength MySS))         ;; loop through length or selection set using SSCount
    (vla-startundomark thisdrawing)          ;; Undo mark start for each text
    (setq MyEnt (ssname MySS SSCount))       ;; get the nth item in the selection set entity name
    (setq MyEntGet (entget MyEnt))           ;; get the entity definition from the above
    (setq MTextCoords (text-box-off MyEntGet 0)) ;;Use sub function above to get text coordinates
    (setq MTextWidth (Distance (car MTextCoords) (cadr MTextCoords)))         ;; Existing text width
    (setq MTextHeight (Distance (cadr MTextCoords) (caddr MTextCoords)))        ;; Existing text width
    (setq MyEntGet (subst (cons 41 MTextWidth) (assoc 41 MyEntGet) MyEntGet)) ;; Adjust modified text width
    (setq MyEntGet (subst (cons 46 MTextHeight) (assoc 46 MyEntGet) MyEntGet)) ;; Adjust modified text width
    (entmod MyEntGet)                        ;; Modify the text
    (vla-endundomark thisdrawing)            ;;End undo mark for this text string
    (setq SSCount (+ SSCount 1))
  ) ; end while

  (princ)
); end function

 

Edited January 24 by Steven P
Added text height as well as width

[stuie444]

Thanks Steven.  I saw that post but didn't catch that part of the code did the same thing.  However, upon testing it only appears to affect box width, whereas double-clicking the ruler arrows shrinks both the width and the height.

I'll review that post to see if that was discussed at all - maybe they already came up with a solution...

[stuie444]

After a bit more searching I came across this LISP from 2009 that seems to work!  It is actually for applying masking to Mtext, but that's a bonus because we would be doing that anyways.  Part of the routine is to shrink the textbox both horizontally and vertically - so it works fine for my purpose.  All credit to the original authors.

This still doesn't work on MLeaders or dimensions like the original code from the 1st post...but you can't win them all I guess!

 

;;; ;BA.lsp  -BACKGROUND FILL ALL-
;;; ;Made for M3 Mexicana. Coding Selected by Paulo Gil. December 2009
;;; ;This routine will set a background color fill to all selected text, 
;;; ;mtext and dimensions, it will update dimensions to current Dimstyle
;;; with
;;; ;Dimtfill set to 1 temporarily for this purpose, so it works for current 
;;; ;Dimscale only, text objects will be converted to mtext with width=0
;;; ;and then will add their text box control points
;;; ;It will bring objects in layer 'Dims' to front at the end, as well as other
;;; ;Draworder operations according to M3 standards.
;;; ;Reviewed and modified by: Alan J. Thompson.
;;; ;And Marco Antonio Jacinto Perez 'mcoan001@hotmail.com'
;;; ;December 2009
;;;
;;; ; Some part of code from Tom Beauford, from AUGI
;;; ;[url]http://forums.augi.com/showthread.php?t=77962[/url]
;;; ; Set 'Border Offset Factor' to 1.15
(VL-LOAD-COM)
(DEFUN c:BA (/ *error* ttm2 ss elist sel1 sel3 dimt)
;;; error handler
 (DEFUN *error* (#Message)
   (AND dimt (SETVAR "dimtfill" dimt))
   (AND #Message
 (NOT (WCMATCH (STRCASE #Message) "*BREAK*,*CANCEL*,*QUIT*"))
 (PRINC (STRCAT "\nError: " #Message))
   ) ;_ and
 ) ;_ defun
 ;;Using code from Roberto Gonzalez -robierzogg- from HISPACAD
 ;; [url]http://www.hispacad.com/foro/viewtopic.php?p=142823&sid=b23c3147d2a06a29d1dfd60078f79c08[/url]
;;;This routine works only if Express tools are installed
;;; Convert selected text into Mtext 

 (COMMAND "undo" "begin")  ;beginning of undo group
 (DEFUN ttm2 (name_n / collect n name_n insertpt name_n1 newlist)
   (SETQ insertpt (ASSOC 10 (ENTGET name_n)))
    ; Convert Text to Mtext, using the
    ; EXPRESS
    ; command
   (COMMAND "txt2mtxt" name_n "")
    ; We set their original insertion point
    ; here
;;;creo que esta parte mueve los nuevos mtextos de posicion hacia arriba
;;;no se por que lo pusieron?
   (SETQ name_n1 (ENTLAST))
   (SETQ newlist (SUBST insertpt
   (ASSOC 10 (ENTGET name_n1))
   (ENTGET name_n1)
   )
   )
   (ENTMOD newlist)
   (SETQ newlist (SUBST '(71 . 7)
   (ASSOC 71 (ENTGET name_n1))
   (ENTGET name_n1)
   )
   )
   (ENTMOD newlist)
   (SETQ newlist (SUBST '(46 . 0)
   (ASSOC 46 (ENTGET name_n1))
   (ENTGET name_n1)
   )
   )
   (ENTMOD newlist)
   (SETQ newlist (SUBST '(41 . 0)
   (ASSOC 41 (ENTGET name_n1))
   (ENTGET name_n1)
   )
   )
   (ENTMOD newlist)
 ) ;_ defun

 ;;
 ;;
;;; Aqui pongo la variable Mtexts como un parametro, el cual corresponde al ss
;;; que vas creando con los nuevos Mtextos
 (DEFUN mw5 (mtexts / mtexts idx ename EntData dxf42 dxf43 EntData1)
    ;Reset Width - Mtext
   (IF mtexts
;;;Aqui se hace el cambio para que en lugar
;;; de cambiar todos los mtextos, solo modifique los que recien creaste
;;;(setq mtexts (ssget "_X" '((0 . "MTEXT"))))
     (PROGN
(SETQ idx 0)
(REPEAT (SSLENGTH mtexts)
  (SETQ ename (SSNAME mtexts idx))
  (SETQ EntData (ENTGET ename '("*")))
  (SETQ dxf42 (* (CDR (ASSOC 42 EntData))1.015))
  (SETQ dxf43 (CDR (ASSOC 43 EntData)))
  (SETQ EntData1
  (ENTMOD (SUBST (CONS 41 dxf42) (ASSOC 41 EntData) EntData))
  )
  (ENTMOD (SUBST (CONS 46 dxf43) (ASSOC 46 EntData1) EntData1)
  )
  (SETQ idx (1+ idx))
)    ;progn
     )     ;repeat
     (PRINC "\n Null Selection!")
   )     ;if
   (PRINC)
 )

 ;;
 ;;
 ;;    ; MAIN ROUTINE
 ;;
 ;;
 (SETQ dimt (GETVAR "dimtfill"))
 (SETVAR "dimtfill" 1)
 (PRINC
   "\nSelect Dimensions and text to apply the background fill and update...: "
 )
 (AND (SETQ ss (SSGET "_:L" '((0 . "MTEXT,*DIMENSION*,TEXT"))))
      (FOREACH x (VL-REMOVE-IF 'LISTP (MAPCAR 'CADR (SSNAMEX ss)))
 (COND
   ((EQ "MTEXT" (CDR (ASSOC 0 (SETQ elist (ENTGET x)))))
    (VLA-PUT-BACKGROUNDFILL
      (VLAX-ENAME->VLA-OBJECT x)
      :VLAX-TRUE
    )
    (SETQ elist (SUBST (CONS 41 0.0) (ASSOC 41 elist) elist)
   elist (SUBST (CONS 46 0.0) (ASSOC 46 elist) elist)
   elist (SUBST (CONS 45 1.15) (ASSOC 45 elist) elist)
   elist (SUBST (CONS 421 256) (ASSOC 421 elist) elist)
    ) ;_ setq
    (ENTMOD elist)
   )
   ((EQ "TEXT" (CDR (ASSOC 0 (ENTGET x))))
    (ttm2 x)
    (SSDEL x ss)
    (VLA-PUT-BACKGROUNDFILL
      (VLAX-ENAME->VLA-OBJECT (SETQ elist (ENTLAST)))
      :VLAX-TRUE
    )
    (SSADD elist ss)
    (SETQ elist (ENTGET elist))
    (SETQ elist (SUBST (CONS 45 1.15) (ASSOC 45 elist) elist)
   elist (SUBST (CONS 421 256) (ASSOC 421 elist) elist)
    ) ;_ setq
    (ENTMOD elist)
   )
   (T T)
 ) ;_ cond
      ) ;_ foreach
      (VL-CMDF "_.-dimstyle" "_apply" ss "")
      (VL-CMDF "_.draworder" ss "" "_f")
 ) ;_ and
(setq 
   BkLst 
          '("CENTER LINE2"   "COLUMN ROW BUBBLE2"  "DETAIL BUBBLE 12" 
            "DETAIL BUBBLE2"     "DUST PICK UP POINT2"     "EQUIPMENT TAG2" 
            "FULL SECTION LR2"     "FULL SECTION UD2"     "FULL SECTION2"  
            "MATCH LINE SP2"     "MATCH LINE2"     "NORTH ARROW2"     
            "NOTE BOX2"     "NOTE ENCL2"     "PARTIAL SECTION T2"     
            "PARTIAL SECTION2"     "PLATE2"     "REVISION2"     
            "SAMPLE NUMBER2"     "SECTION CUT UD2"     "SECTION CUT2"     
            "STAMP BIG2"     "STAMP SMALL2"     "STREAM NUMBER2"     
            "STREAM SEQUENCE2"     "TAG2"     "TITLE 12"     
            "TITLE BUBBLE 12"     "TITLE BUBBLE2"     "TITLE2"     
            "WORK POINT2"     "ROOMTAG"     "ROOMTAG2"     "DOORTAG"     
            "WALLTAG"     "WINDOWTAG"     "MULTIPLE DETAIL"     
            "IND WALL CEIL 1"     "IND WALL UP 1"     "IND WALL L 1"  
            "IND WALL R 1"     "IND WALL DN 1"     "MULTIPLE DETAIL"
       ) 
   NomBloques (car BkLst) 
   BkName     (mapcar '(lambda    (x) 
             (setq NomBloques (strcat NomBloques "," x)) 
           ) 
              (cdr BkLst) 
          ) 
 ) 
 (if (setq sel5 (ssget "_X" (list '(-4 . "<OR") 
                   ; _Se seleccionan todos los bloques de 
                   ; usuario, despues se procesaran los 
                   ; nombres esto para poder procesar los 
                   ; bloques dinamicos 
                  '(-4 . "<AND") 
                  '(0 . "INSERT") 
                  (cons 2 (strcat NomBloques ",`*U*")) 
                  '(-4 . "AND>") 
                  '(-4 . "OR>") 
            ) 
         ) 
     ) 

   (VL-CMDF "_.draworder" sel5 "" "_f")
 ) ;_ if
 (IF (SETQ sel4
     (SSGET
       "_X"
       '((0
   .
   "line,lwpolyline,insert,polyline,arc,circle,spline,hatch,region"
  )
 )
     )
     )
   (VL-CMDF "_.draworder" sel4 "" "_b")
 ) ;_ if
 (IF (SETQ sel1 (SSGET "_X" '((0 . "leader,*Dimension*"))))
   (VL-CMDF "_.draworder" sel1 "" "_f")
 ) ;_ if
 (IF (SETQ sel3
     (SSGET "_X"
     '((0 . "line,lwpolyline,polyline")
       (8 . "Dims,Ar-Dims,G-Dims,M-Dims,E-Dims,S-Dims,P-Dims")
      )
     ) ;_ ssget
     ) ;_ setq
   (VL-CMDF "_.draworder" sel3 "" "_f")
 ) ;_ if
 (SETVAR "dimtfill" dimt)
 (PRINC)
 (COMMAND "undo" "end")  ;end of undo group
 (mw5 ss)
) ;_ defun
(PRINC
 "\Type \"BA\" to mask all text, mtext and dimensions, adding mtext box"
)
(PRINC
 "\Remember to set dimscale according to selected dimensions before using it."
)
;|«Visual LISP© Format Options»
(80 2 40 2 nil "end of " 60 9 2 0 0 T T T T)
;*** DO NOT add text below the comment! ***|;

 

[Steven P]

Didn't realise you wanted height as well, I tend to leave height at 0 so never crossed my mind. It is a couple of lines to make the change.

 

I have edited the code above to include for mtext height as well as width, just for completion.

Edited January 24 by Steven P

[Steven P]

I'll come back to leaders and dimensions tomorrow - very similar to text, just slightly different code

[WolfpactVI]

On 1/24/2024 at 4:00 PM, Steven P said:

I'll come back to leaders and dimensions tomorrow - very similar to text, just slightly different code

Steven,

 

I know it's been a few months, but do you think you could update your bit of code to include dimensions?  I have this nice little AutoCAD lisp called entity-box by Juan Cadavid from back in 2004.  It puts boxes around text, mtext and dimension text objects.  I've tweaked it here and there over the years, adding things like user-defined percent offset, default offset value, etc.  The last thing that would be helpful is to add that "double-click the ruler diamond to shrink the mtext bounding box to the minimum" function right into the entity-box lisp.  Currently users have to remember to do that manually before running the entity-box lisp.  Would be nice to have the lisp do it automatically for them.  I also want to add in the ability to select/apply to multiple objects (and even mixed objects, though I don't know if that's possible), but that's a topic for another discussion.  So anyway, I thought I might be able to add in your bit of code above, but the entity-box lisp works on text, mtext and dimensions.

 

Thanks!