Topic: MText creation routine

[T-Square]

Hello All,

I was perplexed with the creation of MText, sought an answer and found some code written by Lee Mac. I have added a few things to it to suit my needs. Please feel free to criticize, pick apart and note how it could be done differently and in your "humble oppinion"...better. Ultimately there are numerous ways to accomplish one thing in the wonderful world of AutoCAD. This suits and works for me. If any of you can find use, please do, if not, then don't use it.

I am including the routine and the error trap I use. Again... Please feel free to criticize, pick apart and note how it could be done differently and in your "humble oppinion"...better.

[ymg]

T-Square,

How about this:

Code - Auto/Visual Lisp: [Select]

1. (defun c:mtx (/ disl p varl)
2.     (vl-load-com)
3.     ;;; Error Handler by ElpanovEvgenyi                                       ;
4.     (defun *error* (msg)
5.         (mapcar 'eval varl)
6.         (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")))
7.            (princ (strcat "\nError: " msg))
8.         )
9.         (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
10.         (princ)
11.     )
12.      
13.     (setq varl '("OSMODE" "CMDECHO"  "CECOLOR" "CELTYPE" "CELWEIGHT" "MTEXTTOOLBAR" "TEXTSTYLE")
14.           varl (mapcar (function (lambda (a) (list 'setvar a (getvar a)))) varl)
15.     )
16.     (setvar 'CMDECHO 0)
17.     (setvar 'MTEXTTOOLBAR 1)
18.     (setvar 'OSMODE 0)
19.     (setvar 'CMDECHO 0)
20.     (setvar 'CECOLOR "bylayer")
21.     (setvar 'CELTYPE "bylayer")
22.     (setvar 'CELWEIGHT -1)
23.  
24.     (setq DISL "A-ANNO-TEXT")
25.     (if (not (tblsearch "layer" DISL))
26.        (command ".-layer" "thaw" DISL "on" DISL "unlock" DISL "make" DISL "color" "4" DISL "lt" "continuous" DISL "")
27.        (progn
28.            (princ (strcat "\nLayer " DISL " Already Exists... Layer Un-Changed... "))
29.            (setvar "clayer" DISL)
30.        )
31.     )
32.     (if (not (tblsearch "style" "Simplex"))
33.        (command ".-style" "SIMPLEX" "simplex.shx" "0.00000000" "0.90000000" "0.00000000" "N" "N" "N")
34.        (princ "\nText Style \"Simplex\" Already Exists... Text Style Un-Changed... ")
35.     )      
36.     (setvar 'TEXTSTYLE "Simplex")
37.    
38.  
39.     (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
40.     (while (setq p (getpoint "\nPoint for MText: "))
41.         (command "_.mtedit" (entmakex
42.                                  (list
43.                                     '(0 . "MTEXT")
44.                                     '(100 . "AcDbEntity")
45.                                     '(100 . "AcDbMText")
46.                                     '(1 . "")
47.                                     (cons 71 9)
48.                                     (cons 10 (trans p 1 0))
49.                                     (cons 40 (if (< (getvar 'tilemode) 1 (getvar 'cvport)) 1 (getvar 'DIMSCALE)))
50.                                     (cons  7 (getvar 'TEXTSTYLE))
51.                                  )
52.  
53.                             )
54.         )
55.     )
56.     (*error* nil)
57. )  
58.  

You can change your justification on the MTextToolbar.

Take a good look at Evgenyi's error handler, this a thing of beauty.

Also nice by BlackBox test (< (getvar 'tilemode) 1 (getvar 'cvport))


ymg

[Lee Mac]

Here is my take on the routine:

Code: [Select]

(defun c:mttl nil (mt 1))
(defun c:mttc nil (mt 2))
(defun c:mttr nil (mt 3))
(defun c:mtml nil (mt 4))
(defun c:mtmc nil (mt 5))
(defun c:mtmr nil (mt 6))
(defun c:mtbl nil (mt 7))
(defun c:mtbc nil (mt 8))
(defun c:mtbr nil (mt 9))

(defun mt ( jus / *error* hgt ins lay sty )

    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )

    (setq hgt 0.125
          sty "SIMPLEX"
          lay "MT"
    )
    (if (setq ins (getpoint "\nSpecify insertion point: "))
        (progn
            (LM:startundo (LM:acdoc))
            (LM:createlayer lay 4 "Continuous" aclnwtbylwdefault 1)
            (LM:createstyle sty "simplex.shx" 0.0 0.9 0.0)
            (if (/= 1 (getvar 'cvport))
                (setq hgt (* hgt (getvar 'dimscale)))
            )
            (command "_.mtedit"
                (entmakex
                    (list
                       '(000 . "MTEXT")
                       '(100 . "AcDbEntity")
                       '(100 . "AcDbMText")
                       '(001 . "")
                        (cons 008 lay)
                        (cons 010 (trans ins 1 0))
                        (cons 011 (getvar 'ucsxdir))
                        (cons 040 hgt)
                        (cons 071 jus)
                        (cons 007 (if (tblsearch "style" sty) sty "Standard"))
                        (cons 210 (trans '(0.0 0.0 1.0) 1 0 t))
                    )
                )
            )
            (LM:endundo (LM:acdoc))
        )
    )
    (princ)
)

;; Create/Modify Layer  -  Lee Mac

(defun LM:createlayer ( lay col ltp lwt plt )
    (
        (lambda ( _function )
            (_function
                (list
                   '(000 . "LAYER")
                   '(100 . "AcDbSymbolTableRecord")
                   '(100 . "AcDbLayerTableRecord")
                   '(070 . 0)
                    (cons 002 lay)
                    (cons 006 (if (tblsearch "ltype" ltp) ltp "Continuous"))
                    (cons 062 col)
                    (cons 290 plt)
                    (cons 370 lwt)
                )
            )
        )
        (if (tblsearch "layer" lay)
            (lambda ( lst ) (entmod (cons (cons -1 (tblobjname "layer" lay)) lst)))
            entmakex
        )
    )
)

;; Create/Modify Text Style  -  Lee Mac

(defun LM:createstyle ( sty fnt hgt wid obl )
    (
        (lambda ( _function )
            (_function
                (list
                   '(000 . "STYLE")
                   '(100 . "AcDbSymbolTableRecord")
                   '(100 . "AcDbTextStyleTableRecord")
                   '(070 . 0)
                    (cons 002 sty)
                    (cons 003 fnt)
                    (cons 040 hgt)
                    (cons 041 wid)
                    (cons 050 obl)
                )
            )
        )
        (if (tblsearch "style" sty)
            (lambda ( lst ) (entmod (cons (cons -1 (tblobjname "style" sty)) lst)))
            entmakex
        )
    )
)

;; Start Undo  -  Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
    (LM:endundo doc)
    (vla-startundomark doc)
)

;; End Undo  -  Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark doc)
    )
)

;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
    (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (LM:acdoc)
)

(vl-load-com) (princ)

[alanjt]

Here is my take on the routine:

Slight mod to account for creating empty text objects...

Code: [Select]

(defun mt (jus / *error* hgt ins lay sty mtext)

  (defun *error* (msg)
    (if (and (eq (type mtext) 'ENT) (eq (cdr (assoc 1 (entget mtext))) "")) ;alanjt edit
      (entdel mtext)
    )
    (LM:endundo (LM:acdoc))
    (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
      (princ (strcat "\nError: " msg))
    )
    (princ)
  )

  (setq hgt 0.125
        sty "SIMPLEX"
        lay "MT"
  )
  (if (setq ins (getpoint "\nSpecify insertion point: "))
    (progn
      (LM:startundo (LM:acdoc))
      (LM:createlayer lay 4 "Continuous" aclnwtbylwdefault 1)
      (LM:createstyle sty "simplex.shx" 0.0 0.9 0.0)
      (if (/= 1 (getvar 'cvport))
        (setq hgt (* hgt (getvar 'dimscale)))
      )
      (command "_.mtedit"
               (setq mtext (entmakex ; alanjt edit
                             (list
                               '(000 . "MTEXT")
                               '(100 . "AcDbEntity")
                               '(100 . "AcDbMText")
                               '(001 . "")
                               (cons 008 lay)
                               (cons 010 (trans ins 1 0))
                               (cons 011 (getvar 'ucsxdir))
                               (cons 040 hgt)
                               (cons 071 jus)
                               (cons 007
                                     (if (tblsearch "style" sty)
                                       sty
                                       "Standard"
                                     )
                               )
                               (cons 210 (trans '(0.0 0.0 1.0) 1 0 t))
                             )
                           )
               )
      )
      (if (eq (cdr (assoc 1 (entget mtext))) "") ;alanjt edit
        (entdel mtext)
      )
      (LM:endundo (LM:acdoc))
    )
  )
  (princ)
)

[CAB]

That's the way I would do it Lee & great add on Alan.
I might keep some options open with this:

Code - Auto/Visual Lisp: [Select]

1. (defun c:mttl nil (mt 1))
2. (defun c:mttc nil (mt 2))
3. (defun c:mttr nil (mt 3))
4. (defun c:mtml nil (mt 4))
5. (defun c:mtmc nil (mt 5))
6. (defun c:mtmr nil (mt 6))
7. (defun c:mtbl nil (mt 7))
8. (defun c:mtbc nil (mt 8))
9. (defun c:mtbr nil (mt 9))
10. (defun mt ( jus )
11.     (mt-sub jus
12.             (if mtDefaultSize mtDefaultSize (setq mtDefaultSize 0.125))
13.             "SIMPLEX"
14.             "MT")
15.  )
16.  
17.  
18. (defun mt-sub ( jus hgt sty lay / *error* hgt ins lay sty )

You can add additional mt routines that allow layer and style options if need be.

[Lee Mac]

Great suggestions guys