text writings four processes font height

December 14

Hello,

I can no longer reach the owner of the lisp because Autodesk archived and deleted the topics

I have a lisp that performs four operations between two texts and prints the result to the screen as a new text. The problem is that I cannot adjust the height of the newly created text. How can I adjust the height I want?

; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/lisp-to-subtract-2-given-mtexts/td-p/5131450




(defun c:AV (/) (c:CombineValues))
(defun c:CombineValues (/ *error* AT:ExtractNumbers AT:Str2Lst AT:MText AT:Entsel AT:ListSelect
                        CV:StripFormat _sel dZin f i obj num nStr final pt
                       )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; SUBROUTINES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;; error handler
  (defun *error* (msg)
    (and dZin (setvar 'dimzin dZin))
    (and msg
         (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*"))
         (princ (strcat "\nError: " msg))
    )
  )



;;; Extract numbers from string
;;; #String - String to extract numbers from
;;; Required Subroutines: AT:Str2Lst
;;; Alan J. Thompson, 11.13.09 / 04.08.10
  (defun AT:ExtractNumbers (Str / i l)
    (setq i -1)
    (mapcar
      (function atof)
      (AT:Str2Lst
        (vl-list->string
          (mapcar
            (function (lambda (x)
                        (setq i (1+ i))
                        (cond ;; number
                              ((< 47 x 58) x)
                              ;; - and number following
                              ((and (eq x 45) (< 47 (nth (1+ i) l) 58)) x)
                              ;; . and follows a number
                              ((and (eq x 46) (not (minusp (1- i))) (< 47 (nth (1- i) l) 58)) x)
                              (t 32)
                        )
                      )
            )
            (setq l (vl-string->list (vl-princ-to-string Str)))
          )
        )
        " "
      )
    )
  )




;;; Convert string to list, based on separator
;;; #Str - String to convert
;;; #Sep - Separator to break string into items
;;; Ex. - (AT:Str2Lst "1,2,3" ",") -> '("1" "2" "3")
;;; Alan J. Thompson, 11.11.09
  (defun AT:Str2Lst (#Str #Sep / #Inc #List #Str)
    (while (setq #Inc (vl-string-search #Sep #Str))
      (setq #List (cons (substr #Str 1 #Inc) #List))
      (setq #Str (substr #Str (+ 2 #Inc)))
    ) ;_ while
    (vl-remove "" (append (reverse #List) (list #Str)))
  ) ;_ defun




;;; Add MText to drawing
;;; Pt - MText insertion point
;;; Str - String to place in created MText object
;;; Wd - Width of MText object (if nil, will be 0 width)
;;; Lay - Layer to place Mtext object on (nil for current)
;;; Jus - Justification # for Mtext object
;;;       1 or nil= TopLeft
;;;       2= TopCenter
;;;       3= TopRight
;;;       4= MiddleLeft
;;;       5= MiddleCenter
;;;       6= MiddleRight
;;;       7= BottomLeft
;;;       8= BottomCenter
;;;       9= BottomRight
;;; Alan J. Thompson, 05.23.09 / 04.09.10
  (defun AT:MText (Pt Str Wd Lay Jus / Wd s o)
    (or Wd (setq Wd 0.))
    (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
    (setq s  (if (or (eq acmodelspace (vla-get-activespace *AcadDoc*))
                     (eq :vlax-true (vla-get-mspace *AcadDoc*))
                 )
               (vla-get-modelspace *AcadDoc*)
               (vla-get-paperspace *AcadDoc*)
             )
          Pt (cond ((vl-consp Pt) (vlax-3d-point Pt))
                   ((eq (type Pt) 'variant) Pt)
             )
    )
    (vla-put-lock (vlax-ename->vla-object (tblobjname "layer" (getvar 'clayer))) :vlax-false)
    (setq o (vla-addMText s Pt Wd (vl-princ-to-string Str)))
    (and Lay (tblsearch "layer" Lay) (vla-put-layer o Lay))
    (cond ((vl-position Jus '(1 2 3 4 5 6 7 8 9))
           (vla-put-AttachmentPoint o Jus)
           (vla-put-InsertionPoint o Pt)
          )
    )
    o
  )




;;; Entsel or NEntsel with options
;;; #Nested - Entsel or Nentsel (T for Nentsel, nil for Entsel)
;;; #Message - Selection message (if nil, "\nSelect object: " is used)
;;; #FilterList - DXF ssget style filtering (nil if not required)
;;;               "V" as first item in list to convert object to VLA-OBJECT (must be in list if no DXF filtering)
;;;               "L" as first item in list to ignore locked layers (must be in list if no DXF filtering)
;;; #Keywords - Keywords to match instead of object selection (nil if not required)
;;; Example: (AT:Entsel nil "\nSelect MText not on 0 layer [Settings]: " '("LV" (0 . "MTEXT")(8 . "~0")) "Settings")
;;; Example: (AT:Entsel T "\nSelect object [Settings]: " '("LV") "Settings")
;;; Alan J. Thompson, 04.16.09
;;; Updated: Alan J. Thompson, 06.04.09 (changed filter coding to work as ssget style dxf filtering)
;;; Updated: Alan J. Thompson, 09.07.09 (added option to ignore locked layers and convert object to VLA-OBJECT
;;; Updated: Alan J. Thompson, 09.18.09 (fixed 'missed pick' alert)
  (defun AT:Entsel (#Nested #Message #FilterList #Keywords / #Count #Message #Choice #Ent
                    #VLA&Locked #FilterList
                   )
    (vl-load-com)
    (setvar "errno" 0)
    (setq #Count 0)
    ;; fix message
    (or #Message (setq #Message "\nSelect object: "))
    ;; set entsel/nentsel
    (if #Nested
      (setq #Choice nentsel)
      (setq #Choice entsel)
    ) ;_ if
    ;; check if option to convert to vla-object or ignore locked layers in #FilterList variable
    (and (vl-consp #FilterList)
         (eq (type (car #FilterList)) 'STR)
         (setq #VLA&Locked (car #FilterList)
               #FilterList (cdr #FilterList)
         ) ;_ setq
    ) ;_ and
    ;; select object
    (while (and (not #Ent) (/= (getvar "errno") 52))
      ;; if keywords
      (and #Keywords (initget #Keywords))
      (cond
        ((setq #Ent (#Choice #Message))
         ;; if ignore locked layers
         (and
           #VLA&Locked
           (vl-consp #Ent)
           (wcmatch (strcase #VLA&Locked) "*L*")
           (not (zerop (cdr (assoc 70
                                   (entget (tblobjname "layer" (cdr (assoc 8 (entget (car #Ent))))) ;_ tblobjname
                                   ) ;_ entget
                            ) ;_ assoc
                       ) ;_ cdr
                ) ;_ zerop
           ) ;_ not
           (setq #Ent nil
                 #Flag T
           ) ;_ setq
         ) ;_ and
         ;; #FilterList check
         (if (and #FilterList (vl-consp #Ent))
           ;; process filtering from #FilterList
           (or
             (not
               (member
                 nil
                 (mapcar '(lambda (x)
                            (wcmatch
                              (strcase (vl-princ-to-string (cdr (assoc (car x) (entget (car #Ent))))) ;_ vl-princ-to-string
                              ) ;_ strcase
                              (strcase (vl-princ-to-string (cdr x)))
                            ) ;_ wcmatch
                          ) ;_ lambda
                         #FilterList
                 ) ;_ mapcar
               ) ;_ member
             ) ;_ not
             (setq #Ent nil
                   #Flag T
             ) ;_ setq
           ) ;_ or
         ) ;_ if
        )
      ) ;_ cond
      (and (or (= (getvar "errno") 7) #Flag)
           (/= (getvar "errno") 52)
           (not #Ent)
           (setq #Count (1+ #Count))
           (prompt (strcat "\nNope, keep trying!  " (itoa #Count) " missed pick(s).") ;_ strcat
           ) ;_ prompt
      ) ;_ and
    ) ;_ while
    (if (and (vl-consp #Ent) #VLA&Locked (wcmatch (strcase #VLA&Locked) "*V*")) ;_ and
      (vlax-ename->vla-object (car #Ent))
      #Ent
    ) ;_ if
  ) ;_ defun



 ;list select dialog
 ;create a temp DCL multi-select list dialog from provided list
 ;value is returned in list form, DCL file is deleted when finished
 ;example: (setq the_list (AT:listselect "This is my list title" "Select items to make a list" "25" "30" "true" (list "object 1" "object 2" "object 3"))
 ;if mytitle is longer than defined width, the width will be ignored and it will fit to title string
 ;if mylabel is longer than defined width, mylabel will be truncated
 ;myheight and mywidth must be strings, not numbers
 ;mymultiselect must either be "true" or "false" (true for multi, false for single)
 ;created by: alan thompson, 9.23.08
 ;some coding borrowed from http://www.jefferypsanders.com (thanks for the DCL examples)

  (defun AT:ListSelect (mytitle ;title for dialog box
                        mylabel ;label right above list box
                        myheight ;height of dialog box !!*MUST BE STRING*!!
                        mywidth ;width of dialog box !!*MUST BE STRING*!!
                        mymultiselect ;"true" for multiselect, "false" for single select
                        mylist ;list to display in list box
                        / retlist readlist count item savevars fn fo valuestr dcl_id
                       )
    (defun saveVars (/ readlist count item)
      (setq retList (list))
      (setq readlist (get_tile "mylist"))
      (setq count 1)
      (while (setq item (read readlist))
        (setq retlist (append retList (list (nth item myList))))
        (while
          (and
            (/= " " (substr readlist count 1))
            (/= "" (substr readlist count 1))
          )
           (setq count (1+ count))
        )
        (setq readlist (substr readlist count))
      )
    ) ;defun
    (setq fn (vl-filename-mktemp "" "" ".dcl"))
    (setq fo (open fn "w"))
    (setq valuestr (strcat "value = \"" mytitle "\";"))
    (write-line (strcat "list_select : dialog {
            label = \"" mytitle "\";") fo)
    (write-line
      (strcat
        "          : column {
            : row {
              : boxed_column {
               : list_box {
                  label =\"" mylabel
        "\";
                  key = \"mylist\";
                  allow_accept = true;
                  height = " myheight ";
                  width = " mywidth ";
                  multiple_select = " mymultiselect
        ";
                  fixed_width_font = false;
                  value = \"0\";
                }
              }
            }
            : row {
              : boxed_row {
                : button {
                  key = \"accept\";
                  label = \" Okay \";
                  is_default = true;
                }
                : button {
                  key = \"cancel\";
                  label = \" Cancel \";
                  is_default = false;
                  is_cancel = true;
                }
              }
            }
          }
}"     )
      fo
    )
    (close fo)
    (setq dcl_id (load_dialog fn))
    (new_dialog "list_select" dcl_id)
    (start_list "mylist" 3)
    (mapcar 'add_list myList)
    (end_list)
    (action_tile "cancel" "(setq ddiag 1)(done_dialog)")
    (action_tile "accept" "(setq ddiag 2)(saveVars)(done_dialog)")
    (start_dialog)
    (if (= ddiag 1)
      (setq retlist nil)
    )
    (unload_dialog dcl_id)
    (vl-file-delete fn)
    retlist
  ) ;defun





  ;;  StripFormat as taken (with permission) from the following:
  ;;  StripMtext Version 5.0b for AutoCAD 2000 and above
  ;;  Copyright© Steve Doman and Joe Burke 2010
  ;; Location: http://www.theswamp.org/index.php?topic=31584.0
  ;; Arguments:
  ;; str - an mtext string.
  ;; formats - a list of format code strings or a string.
  ;; Format code arguments are not case sensitive.
  ;; Examples:
  ;; Remove Font, Overline and Underline formatting.
  ;; (StripFormat <mtext string> (list "f" "O" "U"))
  ;; Or a quoted list:
  ;; (StripFormat <mtext string> '("f" "O" "U"))
  ;; Or a string:
  ;; (StripFormat <mtext string> "fOU")
  ;; Remove all formatting except Overline and Underline.
  ;; (StripFormat <mtext string> (list "*" "^O" "^U"))
  ;; Or a quoted list:
  ;; (StripFormat <mtext string> '("*" "^O" "^U"))
  ;; Or a string:
  ;; (StripFormat <mtext string> "*^O^U")
  ;; Available codes:
  ;; A (^A) - Alignment
  ;; B (^B) - taBs
  ;; C (^C) - Color
  ;; F (^F) - Font
  ;; H (^H) - Height
  ;; L (^L) - Linefeed (newline, line break, carriage return)
  ;; O (^O) - Overline
  ;; Q (^Q) - obliQuing
  ;; P (^P) - Paragraph (embedded justification, line spacing and indents)
  ;; S (^S) - Stacking
  ;; T (^T) - Tracking
  ;; U (^U) - Underline
  ;; W (^W) - Width
  ;; ~ (^~) - non-breaking space
  ;; * - all formats
  (defun CV:StripFormat (str formats / FormatsToList text slashflag lbrace rbrace RE:Replace
                         RE:Execute Alignment Tab Color Font Height Linefeed Overline Paragraph
                         Oblique Stacking Tracking Underline Width Braces HardSpace
                        )
    ;; Argument: either a list of strings or a string.
    ;; Given a list, ensure formats are uppercase.
    ;; Given a formats string, convert it to a list of uppercase strings.
    ;; Examples: (FormatsToList "fOU") > ("F" "O" "U")
    ;;           (FormatsToList "f^OU") > ("F" "^O" "U")
    (defun FormatsToList (arg / lst)
      (cond ((= (type arg) 'LIST) (mapcar 'strcase arg))
            ((= (type arg) 'STR)
             (while (not (eq "" (substr arg 1)))
               (if (eq "^" (substr arg 1 1))
                 (setq lst (cons (strcat "^" (substr arg 2 1)) lst)
                       arg (substr arg 3)
                 )
                 (setq lst (cons (substr arg 1 1) lst)
                       arg (substr arg 2)
                 )
               )
             )
             (mapcar 'strcase (reverse lst))
            )
      )
    ) ; end FormatsToList  
    (setq formats (FormatsToList formats))
    ;; Access the RegExp object from the blackboard.
    ;; Thanks to Steve for this idea.
    (or (vl-bb-ref '*REX*) (vl-bb-set '*REX* (vlax-create-object "VBScript.RegExp")))
    (defun RE:Replace (newstr pat string)
      (vlax-put (vl-bb-ref '*REX*) 'Pattern pat)
      (vlax-put (vl-bb-ref '*REX*) 'Global actrue)
      (vlax-put (vl-bb-ref '*REX*) 'IgnoreCase acfalse)
      (vlax-invoke (vl-bb-ref '*REX*) 'Replace string newstr)
    ) ;end
    (defun RE:Execute (pat string / result match idx lst)
      (vlax-put (vl-bb-ref '*REX*) 'Pattern pat)
      (vlax-put (vl-bb-ref '*REX*) 'Global actrue)
      (vlax-put (vl-bb-ref '*REX*) 'IgnoreCase acfalse)
      (setq result (vlax-invoke (vl-bb-ref '*REX*) 'Execute string))
      (vlax-for x result
        (setq match (vlax-get x 'Value)
              idx   (vlax-get x 'FirstIndex)
              ;; position within string - zero based - first position is zero
              lst   (cons (list match idx) lst)
        )
      )
      lst
    ) ;end
    ;; Replace linefeeds using this format "\n" with the AutoCAD
    ;; standard format "\P". The "\n" format occurs when text is
    ;; copied to ACAD from some other application.
    (setq str (RE:Replace "\\P" "\\n" str))
;;;;; Start remove formatting sub-functions ;;;;;
    ;; A format
    (defun Alignment (str) (RE:Replace "" "\\\\A[012];" str))
    ;; B format (tabs)
    (defun Tab (str / lst origstr tempstr)
      (setq lst (RE:Execute "\\\\P\\t|[0-9]+;\\t" str))
      (foreach x lst
        (setq origstr (car x)
              tempstr (RE:Replace "" "\\t" origstr)
              str     (vl-string-subst tempstr origstr str)
        )
      )
      (RE:Replace " " "\\t" str)
    )
    ;; C format
    (defun Color (str)
      ;; True color and color book integers are preceded
      ;; by a lower case "c". Standard colors use upper case "C".
      (RE:Replace "" "\\\\[Cc][0-9]?[.]?[0-9]+;" str)
    )
    ;; F format
    (defun Font (str) (RE:Replace "" "\\\\[Ff].*?;" str))
    ;; H format
    (defun Height (str)
      (RE:Replace "" "\\\\H[0-9]?[.]?[0-9]+x;" str)
      ;; This also works, but it's not as clear as the above.
      ;; (RE:Replace "" "\\\\H\\d\\.?\\d*x;" str)
    )
    ;; L format
    ;; Leading linefeeds are not converted to spaces.
    (defun Linefeed (str / teststr)
      ;; Remove formatting from test string other than linefeeds.
      ;; Seems there's no need to check for stacking
      ;; because a linefeed will always come before stack formatting.
      (setq teststr (Alignment str)
            teststr (Color teststr)
            teststr (Font teststr)
            teststr (Height teststr)
            teststr (Overline teststr)
            teststr (Paragraph teststr)
            teststr (Oblique teststr)
            teststr (Tracking teststr)
            teststr (Underline teststr)
            teststr (Width teststr)
            teststr (Braces teststr)
      )
      ;; Remove leading linefeeds.
      (while (eq "\\P" (substr teststr 1 2))
        (setq teststr (substr teststr 3)
              str     (vl-string-subst "" "\\P" str)
        )
      )
      (RE:Replace " " " \\\\P|\\\\P |\\\\P" str)
    )
    ;; O format
    (defun Overline (str) (RE:Replace "" "\\\\[Oo]" str))
    ;; This option is effectively the same as the Remove Formatting >
    ;; Remove Paragraph Formatting option avaiable in the 2008 Mtext editor.
    (defun Paragraph (str) (RE:Replace "" "\\\\p.*?;" str))
    ;; Q format - numeric value may be negative.
    (defun Oblique (str)
      ;; Any real number including negative values.
      (RE:Replace "" "\\\\Q[-]?[0-9]*?[.]?[0-9]+;" str)
    )
    ;; S format
    (defun Stacking (str / lst tempstr pos origstr teststr testpos numcheck)
      (setq lst (RE:Execute "\\\\S(.*?)(\\;)" str))
      (foreach x lst
        (setq tempstr (car x)
              pos     (cadr x)
              origstr tempstr
        )
        ;; Remove formatting from test string other than stacking.
        (setq teststr (Alignment str)
              teststr (Color teststr)
              teststr (Font teststr)
              teststr (Height teststr)
              teststr (Linefeed teststr)
              teststr (Overline teststr)
              teststr (Paragraph teststr)
              teststr (Oblique teststr)
              teststr (Tracking teststr)
              teststr (Underline teststr)
              teststr (Width teststr)
              teststr (Braces teststr)
        )
        ;; Remove all "{" characters if present. Added JB 2/1/2010.
        (setq teststr (RE:Replace "" "[{]" teststr))
        ;; Get the stacked position within test string.
        (setq testpos (cadar (RE:Execute "\\\\S(.*?)(\\;)" teststr)))
        ;; Avoid an error with substr if testpos is zero.
        ;; A space should not be added given a stacked
        ;; fraction string which is simply like this 1/2" anyway.
        (if (/= 0 testpos)
          (setq numcheck (substr teststr testpos 1))
        )
        ;; Check whether the character before a stacked string/fraction 
        ;; is a number. Add a space if it is.
        (if (and numcheck (<= 48 (ascii numcheck) 57))
          (setq tempstr (RE:Replace " " "\\\\S" tempstr))
          (setq tempstr (RE:Replace "" "\\\\S" tempstr))
        )
        (setq tempstr (RE:Replace "/" "[#]" tempstr)
              tempstr (RE:Replace "" "[;]" tempstr)
              tempstr (RE:Replace "" "\\\\A(.*?)[;]" tempstr)
              tempstr (RE:Replace "" "\\^" tempstr)
              str     (vl-string-subst tempstr origstr str pos)
        )
      )
      str
    )
    ;; T format
    (defun Tracking (str) (RE:Replace "" "\\\\T[0-9]?[.]?[0-9]+;" str))
    ;; U format
    (defun Underline (str) (RE:Replace "" "\\\\[Ll]" str))
    ;; W format
    (defun Width (str) (RE:Replace "" "\\\\W[0-9]?[.]?[0-9]+;" str))
    ;; ~ format
    ;; In 2008 a hard space includes font formatting.
    ;; In 2004 it does not, simply this \\~.
    (defun HardSpace (str) (RE:Replace " " "{\\\\[Ff](.*?)\\\\~}|\\\\~" str))
    ;; Remove curly braces. Called after other formatting is removed.
    (defun Braces (str / lst origstr tempstr len teststr)
      (setq lst (RE:Execute "{[^\\\\]+}" str))
      (foreach x lst
        (setq origstr (car x)
              tempstr (RE:Replace "" "[{}]" origstr)
              str     (vl-string-subst tempstr origstr str)
        )
      )
      ;; Added JB 12/20/2009
      ;; Last ditch attempt at remove braces from start and end of string.
      (setq len (strlen str))
      (if (and (= 123 (ascii (substr str 1 1)))
               (= 125 (ascii (substr str len 1)))
               (setq teststr (substr str 2))
               (setq teststr (substr teststr 1 (1- (strlen teststr))))
               (not (vl-string-search "{" teststr))
               (not (vl-string-search "}" teststr))
          )
        (setq str teststr)
      )
      str
    )
;;;;; End remove formatting sub-functions ;;;;;
;;;;; Start primary function ;;;;;
    ;; Temporarily replace literal backslashes with a unique string.
    ;; Literal backslashes are restored at end of function. By Steve Doman.
    (setq slashflag (strcat "<" (substr (rtos (getvar "CDATE") 2 8) 14) ">"))
    (setq text (RE:Replace slashflag "\\\\\\\\" str))
    ;; Temporarily replace literal left curly brace.
    (setq lbrace (strcat "<L" (substr (rtos (getvar "CDATE") 2 8) 14) ">"))
    (setq text (RE:Replace lbrace "\\\\{" text))
    ;; Temporarily replace literal right curly brace.
    (setq rbrace (strcat "<" (substr (rtos (getvar "CDATE") 2 8) 14) "R>"))
    (setq text (RE:Replace rbrace "\\\\}" text))
    (if (or (vl-position "A" formats)
            (and (vl-position "*" formats) (not (vl-position "^A" formats)))
        )
      (setq text (Alignment text))
    )
    (if (or (vl-position "B" formats)
            (and (vl-position "*" formats) (not (vl-position "^B" formats)))
        )
      (setq text (Tab text))
    )
    (if (or (vl-position "C" formats)
            (and (vl-position "*" formats) (not (vl-position "^C" formats)))
        )
      (setq text (Color text))
    )
    (if (or (vl-position "F" formats)
            (and (vl-position "*" formats) (not (vl-position "^F" formats)))
        )
      (setq text (Font text))
    )
    (if (or (vl-position "H" formats)
            (and (vl-position "*" formats) (not (vl-position "^H" formats)))
        )
      (setq text (Height text))
    )
    (if (or (vl-position "L" formats)
            (and (vl-position "*" formats) (not (vl-position "^L" formats)))
        )
      (setq text (Linefeed text))
    )
    (if (or (vl-position "O" formats)
            (and (vl-position "*" formats) (not (vl-position "^O" formats)))
        )
      (setq text (Overline text))
    )
    (if (or (vl-position "P" formats)
            (and (vl-position "*" formats) (not (vl-position "^P" formats)))
        )
      (setq text (Paragraph text))
    )
    (if (or (vl-position "Q" formats)
            (and (vl-position "*" formats) (not (vl-position "^Q" formats)))
        )
      (setq text (Oblique text))
    )
    (if (or (vl-position "S" formats)
            (and (vl-position "*" formats) (not (vl-position "^S" formats)))
        )
      (setq text (Stacking text))
    )
    (if (or (vl-position "T" formats)
            (and (vl-position "*" formats) (not (vl-position "^T" formats)))
        )
      (setq text (Tracking text))
    )
    (if (or (vl-position "U" formats)
            (and (vl-position "*" formats) (not (vl-position "^U" formats)))
        )
      (setq text (Underline text))
    )
    (if (or (vl-position "W" formats)
            (and (vl-position "*" formats) (not (vl-position "^W" formats)))
        )
      (setq text (Width text))
    )
    (if (or (vl-position "~" formats)
            (and (vl-position "*" formats) (not (vl-position "^~" formats)))
        )
      (setq text (HardSpace text))
    )
    (setq text (Braces (RE:Replace "\\\\" slashflag text))
          text (RE:Replace "\\{" lbrace text)
          text (RE:Replace "\\}" rbrace text)
    )
    text
  ) ; end StripFormat




  (defun _sel (/ o)
    (if (setq o
               (AT:Entsel t
                          (strcat "\nSelect text object to "
                                  *AV:Fnc*
                                  " or "
                                  (if final
                                    "[Add/Divide/Multiply/Subtract/Type]: "
                                    "[Type]: "
                                  )
                          )
                          '("V" (0 . "AECC_COGO_POINT,AECC_POINT,ATTDEF,ATTRIB,MULTILEADER,MTEXT,TEXT"))
                          (if final
                            "Add Divide Multiply Subtract Type"
                            "Type"
                          )
               )
        )
      (cond ((eq o "Add") (setq f "+") (setq *AV:Fnc* "Add") (_sel))
            ((eq o "Divide") (setq f "/") (setq *AV:Fnc* "Divide") (_sel))
            ((eq o "Multiply") (setq f "*") (setq *AV:Fnc* "Multiply") (_sel))
            ((eq o "Subtract") (setq f "-") (setq *AV:Fnc* "Subtract") (_sel))
            ((eq o "Type") (initget 6) (setq o (getreal (strcat "\nNumber to " *AV:Fnc* ": "))))
            (T o)
      )
    )
  )




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MAIN ROUTINE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (vl-load-com)


  (or *AV:Fnc* (setq *AV:Fnc* "Add"))
  (and (setq dZin (getvar 'dimzin)) (setvar 'dimzin 0))

  (initget 0 "Add Divide Multiply Subtract")
  (setq
    *AV:Fnc* (cond ((getkword
                      (strcat "\nChoose function [Add/Divide/Multiply/Subtract] <" *AV:Fnc* ">: ")
                    )
                   )
                   (*AV:Fnc*)
             )
  )
  (setq f (cond ((eq *AV:Fnc* "Add") "+")
                ((eq *AV:Fnc* "Divide") "/")
                ((eq *AV:Fnc* "Multiply") "*")
                ((eq *AV:Fnc* "Subtract") "-")
          )
        i 0.
  )
  (while (setq obj (_sel))
    (if
      (cond
        ;; real value
        ((eq (type obj) 'REAL) (setq num obj))
        ;; LDD point
        ((and (eq (vla-get-objectname obj) "AeccDbPoint")
              (not (vl-catch-all-error-p
                     (setq num (vl-catch-all-apply
                                 (function
                                   (lambda () (cadddr (assoc 11 (entget (vlax-vla-object->ename obj)))))
                                 )
                               )
                     )
                   )
              )
         )
         num
        )
        ;; C3D point
        ((and
           (eq (vla-get-objectname obj) "AeccDbCogoPoint")
           (not (vl-catch-all-error-p
                  (setq num (vl-catch-all-apply (function vlax-get-property) (list obj 'Elevation)))
                )
           )
         )
         (setq num (car (AT:ExtractNumbers num)))
        )
        ;; attribute, multileader, mtext, text
        (T
         ;;(T (setq num (apply (function (eval (read f))) (AT:ExtractNumbers (vla-get-textstring obj)))))
         ;;(T (setq num (car (AT:ExtractNumbers (vla-get-textstring obj)))))
         ;|
         (setq num ((lambda (n)
                      (foreach x (AT:ExtractNumbers (StripFormat (vla-get-textstring obj) "*"))
                        (setq n ((eval (read f)) x n))
                      )
                    )
                     0.
                   )
         )
         |;

         (if
           (> (length (setq num (AT:ExtractNumbers (CV:StripFormat (vla-get-textstring obj) "*"))))
              1
           )
            (if (setq num (AT:ListSelect
                            (strcat "Multiple numbers to: " *AV:Fnc*)
                            "Choose numbers:"
                            "10"
                            "5"
                            "true"
                            (mapcar (function vl-princ-to-string) num)
                          )
                )
              (setq i   (+ i (1- (length num)))
                    num ((lambda (n)
                           (foreach x (mapcar (function atof) num)
                             (setq n ((eval (read f)) x n))
                           )
                         )
                          0.
                        )
              )
            )
            (setq num (car num))
         )

        )
      )
       (if final
         (progn (setq final ((eval (read f)) final num)
                      nStr  (strcat nStr " " f " " (vl-princ-to-string num))
                      i     (1+ i)
                )
                (princ (strcat nStr " = " (vl-princ-to-string final)))
         )
         (progn (setq final num
                      nStr  (strcat "\n" (vl-princ-to-string num))
                      i     (1+ i)
                )
                (princ (strcat nStr " " f))
         )
       )
       (princ "\nValue does not contain number!")
    )
  )
  (and nStr
       (> i 1)
       (if (and (eq *AV:Fnc* "Add") (not (wcmatch nStr "*/*,*`**,*-*")))
         (setq pt (initget 0 "Average")
               pt (getpoint (strcat nStr
                                    " = "
                                    (vl-princ-to-string final)
                                    "\nSpecify text placement or [Average]: "
                            )
                  )
         )
         (setq
           pt (getpoint (strcat nStr " = " (vl-princ-to-string final) "\nSpecify text placement: "))
         )
       )
       (if (vl-consp pt)
         (AT:MText (trans pt 1 0) (rtos final) nil nil 5)
         (if (setq pt (getpoint (strcat nStr
                                        " = "
                                        (vl-princ-to-string final)
                                        " / "
                                        (vl-princ-to-string (fix i))
                                        " = "
                                        (vl-princ-to-string (/ final i))
                                        "\nSpecify text placement point: "
                                )
                      )
             )
           (AT:MText (trans pt 1 0) (rtos (/ final i)) nil nil 5)
         )
       )
  )
  (*error* nil)
  (princ)
)

December 14

You can look at dxf code 40 and entmod or use VL (vlax-put obj 'height ht) or maybe (setvar 'TEXTSIZE ht) before making text.

December 18

On 12/14/2024 at 11:26 PM, BIGAL said:

You can look at dxf code 40 and entmod or use VL (vlax-put obj 'height ht) or maybe (setvar 'TEXTSIZE ht) before making text.

thank you

Sign In

text writings four processes font height

Recommended Posts

thecocuk07

BIGAL

thecocuk07

Join the conversation

Tutorials

Forums

Activity