Lisp routines to insert text fail in UCS

March 19, 2022

Hi,

I've got a variety of fairly simple lisp routines for adding text to drawings. They all work fine in the WCS but not in a UCS.

I can see that there needs to be co-ordinate transformations to make them work in a UCS. This seems to involve the "TRANS" command but even after much googling I can't seem to get my head around it.

Multiple UCSs involve an initial rotation around the z axis that could be any angle, further 90 degree rotations around the z axis, and then 90 degree flips around the x axis.

I've attached three sample routines -

TT - Insert multiple lines of text equally spaced and centred at selected point.

UT - Add multiple lines of equally spaced and centred text under existing selected text.

LH - Inserts MTEXT "Loft" "hatch" at an intersection.

Hopefully someone can point me in the right direction...

(sorry the formatting is a bit messy, they came from a colleague in this state)

Thanks in advance
Quentin.

(DEFUN C:TT (/)
(GRAPHSCR)


(SETQ lll (GETVAR"CLAYER"))
 (SETQ OSM (GETVAR"OSMODE"))
 (COMMAND "OSNAP" "NONE")
(command "layer" "m" "GTEXT" "")


  (setq edp(getpoint "TEXT AT.."))
(setq txt (getstring T "TEXT.."))
   (COMMAND "TEXT" "C" EDP "" 0.0 TXt)


(setq e(entget(entlast)))

	(setq en2(cdr(assoc -1 e)))
	(setq en3(entget en2))   
	(SETQ TYPE1 (CDR (ASSOC 0 EN3)))
		(textun)


(SETVAR "OSMODE" OSM)
  (COMMAND "LAYER" "S" lll "")
   (setq *error* olderr)             ; Restore old *error* handler
   (princ)
)

(DEFUN C:UT (/)
(GRAPHSCR)

;;;EXTRACT EXISTING INFORMATION


(SETQ STYLE1 (GETVAR "TEXTSTYLE"))
(SETQ LAYER1 (GETVAR "CLAYER"))
(SETQ SIZE1 (GETVAR "TEXTSIZE"))
(SETQ COL2 (GETVAR "CECOLOR"))
(SETQ COL3 (ATOI COL2))

;;;SELECT TEXT TO UNDERWRITE

	(SETQ EN1 (ENTSEL "SELECT THE TEXT TO WRITE UNDER: "))
		(WHILE (= EN1 NIL)
			(ALERT "NO TEXT SELECTED")
			(SETQ EN1 (ENTSEL "SELECT THE TEXT TO WRITE UNDER: "))	
		)

	(SETQ EN2 (CAR EN1))
	(SETQ EN3 (ENTGET EN2))


;;;CHECK TO SEE IF TEXT OR MTEXT

	(SETQ TYPE1 (CDR (ASSOC 0 EN3)))
	(IF (= TYPE1 "MTEXT")(COMMAND "DDEDIT" EN1 "")(TEXTUN))
	
;;;RESET EXISTING VALUES

(SETVAR "TEXTSIZE" SIZE1)
(SETVAR "TEXTSTYLE" STYLE1)
(SETVAR "CLAYER" LAYER1)
(SETVAR "CECOLOR" COL2)

(PRINC)

)

(DEFUN C:LH (/)
(GRAPHSCR)

 (SETQ lll (GETVAR"CLAYER"))
 (SETQ OSM (GETVAR"OSMODE"))
 (COMMAND "OSNAP" "INTERSECTION")
 (command "layer" "m" "GTEXT" "")

  (setq edp(getpoint "TEXT AT.."))


   (COMMAND "MTEXT" edp "_Justify" "MC" "_none" "@" "Loft" "hatch" "")


(SETVAR "OSMODE" OSM)
  (COMMAND "LAYER" "S" lll "")
   (setq *error* olderr)             ; Restore old *error* handler
   (princ)
)

This is an example of what happens with the LH lisp in a UCS (see attached screenshots) -

First image is in WCS using LH lisp at triangle point 1 (0,0,0)

Then commands -

UCS
origin at point 1
point on x-axis at point 2

VP (image 2)
Relative to UCS
Set to Plan View
OK

point 1 is now 0,0,0 in the UCS (image 3)

LH lisp at point 1

the text is inserted at 87.282,10.915,0 (image 4)

March 20, 2022

Hi, I could really do with some help here. Thanks.

March 20, 2022

There is another lisp textun not listed here.

(DEFUN C:UT (/)
  (GRAPHSCR) 
  ;;;EXTRACT EXISTING INFORMATION
  (setq lst (list 'TEXTSTYLE 'CLAYER 'TEXTSIZE 'CECOLOR)
        val (mapcar 'getvar lst) 
  )
  ;;;SELECT TEXT TO UNDERWRITE
  (SETQ EN1 (ENTSEL "SELECT THE TEXT TO WRITE UNDER: "))
  (WHILE (= EN1 NIL)
    (ALERT "NO TEXT SELECTED")
    (SETQ EN1 (car (ENTSEL "SELECT THE TEXT TO WRITE UNDER: "))
  )
  ;;;CHECK TO SEE IF TEXT OR MTEXT
  (SETQ TYPE1 (CDR (ASSOC 0 EN1)))
  (IF (= TYPE1 "MTEXT") 
    (COMMAND "DDEDIT" EN1 "") 
    (TEXTUN)
  )
  ;;;RESET EXISTING VALUES
  (mapcar 'setvar lst val)
  (PRINC)
)

(defun C:LH (/ lst val OSM edp)
  (GRAPHSCR)
  (setq lst (list 'cmdecho 'osmode)
        val (mapcar 'getvar lst) 
  )
  (mapcar 'setvar lst '(0 64))
  (if (tblsearch "Layer" "GTEXT")
    (setvar 'clayer "GTEXT")
    (command "-Layer" "M" "GTEXT" "")
  )
  (command "_UCS" "V")
  (setq edp (getpoint "Pick Text Location: "))
  (command "MTEXT" edp "J" "MC" "_none" "@" "Loft" "Hatch" "")
  (command "_UCS" "P")
  (mapcar 'setvar lst val)
  (setq *error* olderr)  ; Restore old *error* handler
  (princ)
)

March 21, 2022

What? I'm not sure what you mean?

March 21, 2022

23 minutes ago, anivegmin said:

What? I'm not sure what you mean?

1. All three of your codes call a function called textun.

You didn't attach this part, need this part for test your code.

It should look something like "(defun textun ...."

2. you can solve that ucs problem with simple way.

- in front of code = (command "ucs" "w")

- end of code = (command "ucs" "p")

- and if cancel or error situation = (command "ucs" "p")

like this

(DEFUN C:TT (/ *error* )
  (setvar "cmdecho" 0)
  (command "ucs" "w")
  (LM:startundo (LM:acdoc))
  ;error control
    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\n Error: " msg))
        )
        (setvar "cmdecho" 1)
        (command "ucs" "p")
        (princ)
    )


(GRAPHSCR)


 (SETQ lll (GETVAR"CLAYER"))
 (SETQ OSM (GETVAR"OSMODE"))
 (COMMAND "OSNAP" "NONE") 
 (command "layer" "m" "GTEXT" "")


 (setq edp(getpoint "TEXT AT.."))
 (setq txt (getstring T "TEXT.."))
 (COMMAND "TEXT" "C" EDP "" 0.0 TXt)

 (setq e(entget(entlast)))
	(setq en2(cdr(assoc -1 e)))
	(setq en3(entget en2))   
	(SETQ TYPE1 (CDR (ASSOC 0 EN3)))
		(textun)


   (SETVAR "OSMODE" OSM)
   (COMMAND "LAYER" "S" lll "")
   (setq *error* olderr)             ; Restore old *error* handler


   (setvar "cmdecho" 1)
   (command "ucs" "p")
   (LM:endundo (LM:acdoc))
   (princ)
)

(DEFUN C:UT (/ *error*)
  (setvar "cmdecho" 0)
  (command "ucs" "w")
  (LM:startundo (LM:acdoc))
  ;error control
    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\n Error: " msg))
        )
        (setvar "cmdecho" 1)
        (command "ucs" "p")
        (princ)
    )



(GRAPHSCR)

;;;EXTRACT EXISTING INFORMATION


(SETQ STYLE1 (GETVAR "TEXTSTYLE"))
(SETQ LAYER1 (GETVAR "CLAYER"))
(SETQ SIZE1 (GETVAR "TEXTSIZE"))
(SETQ COL2 (GETVAR "CECOLOR"))
(SETQ COL3 (ATOI COL2))

;;;SELECT TEXT TO UNDERWRITE

	(SETQ EN1 (ENTSEL "SELECT THE TEXT TO WRITE UNDER: "))
		(WHILE (= EN1 NIL)
			(ALERT "NO TEXT SELECTED")
			(SETQ EN1 (ENTSEL "SELECT THE TEXT TO WRITE UNDER: "))	
		)

	(SETQ EN2 (CAR EN1))
	(SETQ EN3 (ENTGET EN2))


;;;CHECK TO SEE IF TEXT OR MTEXT

	(SETQ TYPE1 (CDR (ASSOC 0 EN3)))
	(IF (= TYPE1 "MTEXT")(COMMAND "DDEDIT" EN1 "")(TEXTUN))
	
;;;RESET EXISTING VALUES

(SETVAR "TEXTSIZE" SIZE1)
(SETVAR "TEXTSTYLE" STYLE1)
(SETVAR "CLAYER" LAYER1)
(SETVAR "CECOLOR" COL2)


   (setvar "cmdecho" 1)
   (command "ucs" "p")
   (LM:endundo (LM:acdoc))

(PRINC)

)

(DEFUN C:LH (/ *error*)
  (setvar "cmdecho" 0)
  (command "ucs" "w")
  (LM:startundo (LM:acdoc))
  ;error control
    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\n Error: " msg))
        )
        (setvar "cmdecho" 1)
        (command "ucs" "p")
        (princ)
    )


(GRAPHSCR)

 (SETQ lll (GETVAR"CLAYER"))
 (SETQ OSM (GETVAR"OSMODE"))
 (COMMAND "OSNAP" "INTERSECTION")
 (command "layer" "m" "GTEXT" "")

  (setq edp(getpoint "TEXT AT.."))


   (COMMAND "MTEXT" edp "_Justify" "MC" "_none" "@" "Loft" "hatch" "")


(SETVAR "OSMODE" OSM)
  (COMMAND "LAYER" "S" lll "")
   (setq *error* olderr)             ; Restore old *error* handler


   (setvar "cmdecho" 1)
   (command "ucs" "p")
   (LM:endundo (LM:acdoc))

   (princ)
)



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


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

You have to copy this code from start to finish (defun LM:endundo~)

There is a more elegant way to solve this, but I'm a beginner, so I solved it in a basic way.

Edited March 21, 2022 by exceed

March 21, 2022

Apologies to mhupp. I just noticed you'd added the UCS commands to the code. I still get the same result though...

Thanks exceed. I still get the same result with (command "ucs" "w") and (command "ucs" "p") added.

BUT... If I change to WCS before using the routine then the UT command works! The LH command places the text correctly but it's rotated to the WCS...

I don't know why the UCS commands used in the lisp routines don't work?

March 21, 2022

On 3/19/2022 at 6:15 PM, anivegmin said:

TT - Insert multiple lines of text equally spaced and centred at selected point.

UT - Add multiple lines of equally spaced and centred text under existing selected text.

(setq e(entget(entlast)))

	(setq en2(cdr(assoc -1 e)))
	(setq en3(entget en2))   
	(SETQ TYPE1 (CDR (ASSOC 0 EN3)))
		(textun)

in TT, this part is just entget entlast.

then save type1 ("TEXT" or "MTEXT"), then run the 'textun'

(textun) do all of 'insert multiple lines of text equally spaced and centred', except 'at selected point' only. that is TT's work.

UT also, entget the TEXT or MTEXT,

if that is mtext, just modify with ddedit command, because MTEXT already can make multi lines text

if that is text, run the (textun), that will do 'insert multiple lines of text equally spaced and centred'.

so, the timing of picking coordinates or making text, which is correct ucs w or ucs p,

will know about (textun). I think

below code has a sketch of textun as I guessed.

try running this TT, UT, LH and again explain which one you want.

(DEFUN C:TT (/ *error* )
  (setvar "cmdecho" 0)
  ;(command "ucs" "w")
  (LM:startundo (LM:acdoc))
  ;error control
    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\n Error: " msg))
        )
        (setvar "cmdecho" 1)
        ;(command "ucs" "p")
        (princ)
    )

 (graphscr)
 (setq lll (getvar "clayer"))
 (setq osm (getvar "osmode"))
 (command "osnap" "none") 
 (command "layer" "m" "GTEXT" "")

 (setq edp (getpoint "\n pick point for first text - "))
 (setq txt (getstring t "\n input first text value - "))
 (command "TEXT" "C" edp "" 0.0 txt)

 (setq e (entget (entlast)))
 (setq en2(cdr(assoc -1 e)))
 (setq en3(entget en2))   
 (setq type1 (cdr (assoc 0 en3)))

 (textun)

 (setvar "osmode" osm)
 (command "layer" "S" lll "")

 (setvar "cmdecho" 1)
 ;(command "ucs" "p")
 (LM:endundo (LM:acdoc))
 (princ)
)

(vl-load-com)
(defun textun ()
  (setq txt (getstring t "\n input text - "))
  (if (= txt "")
     (progn (princ "\n end process \n"))
     (progn
       (setq textlocation '())
       (setq putlocation '())
       (setq ss0 (ssadd en2))
       (setq lst (LM:textbox en3))
       (setq ang (angle (car lst) (last lst)))
       (setq textsize (cdr (assoc 40 en3)))
       (setq textlocation (trans (cdr (assoc 10 en3)) 0 1))
       (setq ucsang (angle '(0 0) (getvar "ucsxdir")))
       (setq ang (- ang ucsang))
       (setq putlocation (polar textlocation (+ ang pi) (* textsize 1.5) ))
       (princ "\n ang - ")
       (princ ang)
       (command "copy" ss0 "" textlocation putlocation)
       (setq ename2 (entlast))
       (setq obj2 (vlax-ename->vla-object ename2))
       ;(vla-put-alignment obj2 1)
       (vla-put-textstring obj2 txt)  
       (setq en2 (vlax-vla-object->ename obj2))
       (setq en3(entget en2))   
       (textun)
     );end of progn
  );end of if
  (princ)
)


(DEFUN C:UT (/ *error*)
  (setvar "cmdecho" 0)
  ;(command "ucs" "w")
  (LM:startundo (LM:acdoc))
  ;error control
    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\n Error: " msg))
        )
        (setvar "cmdecho" 1)
        ;(command "ucs" "p")
        (princ)
    )



(GRAPHSCR)

;;;EXTRACT EXISTING INFORMATION


(SETQ STYLE1 (GETVAR "TEXTSTYLE"))
(SETQ LAYER1 (GETVAR "CLAYER"))
(SETQ SIZE1 (GETVAR "TEXTSIZE"))
(SETQ COL2 (GETVAR "CECOLOR"))
(SETQ COL3 (ATOI COL2))

;;;SELECT TEXT TO UNDERWRITE

	(SETQ EN1 (ENTSEL "SELECT THE TEXT TO WRITE UNDER: "))
		(WHILE (= EN1 NIL)
			(ALERT "NO TEXT SELECTED")
			(SETQ EN1 (ENTSEL "SELECT THE TEXT TO WRITE UNDER: "))	
		)

	(SETQ EN2 (CAR EN1))
	(SETQ EN3 (ENTGET EN2))


;;;CHECK TO SEE IF TEXT OR MTEXT

	(SETQ TYPE1 (CDR (ASSOC 0 EN3)))
	(IF (= TYPE1 "MTEXT")(COMMAND "DDEDIT" EN1 "")(TEXTUN))
	
;;;RESET EXISTING VALUES

(SETVAR "TEXTSIZE" SIZE1)
(SETVAR "TEXTSTYLE" STYLE1)
(SETVAR "CLAYER" LAYER1)
(SETVAR "CECOLOR" COL2)


   (setvar "cmdecho" 1)
   ;(command "ucs" "p")
   (LM:endundo (LM:acdoc))

(PRINC)

)

(DEFUN C:LH (/ *error*)
  (setvar "cmdecho" 0)
  ;(command "ucs" "w")
  (LM:startundo (LM:acdoc))
  ;error control
    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\n Error: " msg))
        )
        (setvar "cmdecho" 1)
        ;(command "ucs" "p")
        (princ)
    )


(GRAPHSCR)

 (SETQ lll (GETVAR"CLAYER"))
 (SETQ OSM (GETVAR"OSMODE"))
 (COMMAND "OSNAP" "INTERSECTION")
 (command "layer" "m" "GTEXT" "")

  (setq edp(getpoint "TEXT AT.."))


   (COMMAND "MTEXT" edp "_Justify" "MC" "_none" "@" "Loft" "hatch" "")


(SETVAR "OSMODE" OSM)
  (COMMAND "LAYER" "S" lll "")
   (setq *error* olderr)             ; Restore old *error* handler


   (setvar "cmdecho" 1)
   ;(command "ucs" "p")
   (LM:endundo (LM:acdoc))

   (princ)
)



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


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



;; Text Box  -  Lee Mac (based on code by gile)
;; Returns the bounding box of a text, mtext, or attribute entity (in OCS)
;; enx - [lst] Text, MText or Attribute DXF data list

(defun LM:textbox ( enx / bpt hgt jus lst ocs org rot wid )
    (cond
        (   (and (= "ATTRIB" (cdr (assoc 000 enx)))
                 (= "Embedded Object" (cdr (assoc 101 enx)))
            )
            (LM:textbox (cons '(000 . "MTEXT") (member '(101 . "Embedded Object") enx)))
        )
        (   (cond
                (   (wcmatch  (cdr (assoc 000 enx)) "ATTRIB,TEXT")
                    (setq bpt (cdr (assoc 010 enx))
                          rot (cdr (assoc 050 enx))
                          lst (textbox enx)
                          lst (list (car lst) (list (caadr lst) (cadar lst)) (cadr lst) (list (caar lst) (cadadr lst)))
                    )
                )
                (   (= "MTEXT" (cdr (assoc 000 enx)))
                    (setq ocs  (cdr (assoc 210 enx))
                          bpt  (trans (cdr (assoc 010 enx)) 0 ocs)
                          rot  (angle '(0.0 0.0) (trans (cdr (assoc 011 enx)) 0 ocs))
                          wid  (cdr (assoc 042 enx))
                          hgt  (cdr (assoc 043 enx))
                          jus  (cdr (assoc 071 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 org (mapcar '+ org (list wid 0)) (mapcar '+ org (list wid hgt)) (mapcar '+ org (list 0 hgt)))
                    )
                )
            )
            (   (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)
                )
            )
        )
    )
)

Edited March 21, 2022 by exceed
edit1 = add while loop for continue , edit2 = can run in ucs rotate and origin moved

March 21, 2022

Thanks very much exceed. The TT and UT commands work perfectly in your latest code. LH does not work (same problem as before). I'm not sure how exactly you've fixed it... I'll have to spend some time analysing the code to understand it properly.

I got LH working separately but the text was rotated to the WCS so I've called another routine within the LH routine to correct it (bit of a bodge on my part and it involves me clicking again but it works)

(DEFUN C:LH (/)
(GRAPHSCR)

 (SETQ lll (GETVAR"CLAYER"))
 (SETQ OSM (GETVAR"OSMODE"))
 (COMMAND "OSNAP" "INTERSECTION")
 (command "layer" "m" "GTEXT" "")

(command "UCS" "W")

  (setq edp(getpoint "TEXT AT.."))


   (COMMAND "MTEXT" edp "_Justify" "MC" "_none" "@" "Loft" "hatch" "")


(SETVAR "OSMODE" OSM)
  (COMMAND "LAYER" "S" lll "")
   (setq *error* olderr)             ; Restore old *error* handler
(command "UCS" "V")
(C:ROV)
   (princ)
)


(defun c:ROV ( / ss2 i vta tmp)
  (vl-load-com)
  (prompt "\n Select TEXT and MTEXT to rotate ")
  (setq ss2 (ssget '((0 . "*TEXT")))
        i   0
        vta (- 0 (getvar "viewtwist"))
  )
  (repeat (sslength ss2)
    (setq tmp (vlax-ename->vla-object (ssname ss2 i)))
    (if (eq (vla-get-ObjectName tmp) "AcDbText")
      (progn
        (vlax-put tmp "Rotation" vta)
        (vlax-put tmp "Alignment" acAlignmentBottomCentre)
      )
      (progn
        (vlax-put tmp "Rotation" 0.0)
        (vlax-put tmp "AttachmentPoint" acAttachmentPointBottomCentre)
      )
    )
    (setq i (1+ i))
  )
)

March 21, 2022

1 hour ago, anivegmin said:

Thanks very much exceed. The TT and UT commands work perfectly in your latest code. LH does not work (same problem as before). I'm not sure how exactly you've fixed it... I'll have to spend some time analysing the code to understand it properly.

I got LH working separately but the text was rotated to the WCS so I've called another routine within the LH routine to correct it (bit of a bodge on my part and it involves me clicking again but it works)

Because I didn't edit anything of "LH" in that post, haha

I still don't know what LH wants, but looking at additional your code,

it seems that you want to make a loft hatch so that not only ucs

but also the view is displayed vertically on the screen even when the view is rotated.

So I merged your two lisp into one and removed the select part.

I hope this helps you.

; command list - 2022.03.21
; TT - Creates the first text, continues the text on the bottom line. (regardless of UCS)
; UT - Selects text that already exists, and creates text from the bottom line (regardless of UCS)
; LH - "Loft Hatch" is created as MTEXT. (Regardless of the angle of the view)

(defun c:TT (/ *error* lll osm edp txt e en2 en3 type1 )
  (setvar "cmdecho" 0)
  (LM:startundo (LM:acdoc))
  ;error control
    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\n Error: " msg))
        )
        (setvar "cmdecho" 1)
        (princ)
    )

 (graphscr)
 (setq lll (getvar "clayer"))
 (setq osm (getvar "osmode"))
 (command "osnap" "none") 
 (command "layer" "m" "GTEXT" "")
 (setq edp (getpoint "\n pick point for first text - "))
 (setq txt (getstring t "\n input first text value - "))
 (command "TEXT" "C" edp "" 0.0 txt)
 (setq e (entget (entlast)))
 (setq en2(cdr(assoc -1 e)))
 (setq en3(entget en2))   

 (textun)

 (setvar "osmode" osm)
 (command "layer" "S" lll "")
 (setvar "cmdecho" 1)
 (LM:endundo (LM:acdoc))
 (princ)
)

(vl-load-com)
(defun textun ( / )
  (setq txt (getstring t "\n input text - "))
  (if (= txt "")
     (progn (princ "\n end process \n"))
     (progn
       (setq textlocation '())
       (setq putlocation '())
       (setq ss0 (ssadd en2))
       (setq lst (LM:textbox en3))
       (setq ang (angle (car lst) (last lst)))
       (setq textsize (cdr (assoc 40 en3)))
       (setq textlocation (trans (cdr (assoc 10 en3)) 0 1))
       (setq ucsang (angle '(0 0) (getvar "ucsxdir")))
       (setq ang (- ang ucsang))
       (setq putlocation (polar textlocation (+ ang pi) (* textsize 1.5) ))
       ;(princ "\n ang - ")
       ;(princ ang)
       (command "copy" ss0 "" textlocation putlocation)
       (setq ename2 (entlast))
       (setq obj2 (vlax-ename->vla-object ename2))
       ;(vla-put-alignment obj2 1)
       (vla-put-textstring obj2 txt)  
       (setq en2 (vlax-vla-object->ename obj2))
       (setq en3 (entget en2))   
       (textun)
     );end of progn
  );end of if
  (princ)
)


(defun c:UT (/ *error* style1 layer1 size1 col2 col3 en1 en2 en3 type1 )
  (setvar "cmdecho" 0)
  (LM:startundo (LM:acdoc))
  ;error control
    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\n Error: " msg))
        )
        (setvar "cmdecho" 1)
        (princ)
    )

  (graphscr)

 ; (setq style1 (getvar "TEXTSTYLE"))
 ; (setq layer1 (getvar "CLAYER"))
 ; (setq size1 (GETVAR "TEXTSIZE"))
 ; (setq col2 (GETVAR "CECOLOR"))
 ; (setq col3 (atoi COL2))

;;;SELECT TEXT TO UNDERWRITE

  (setq en1 (entsel "\n Select the TEXT to write under - "))
  (while (= en1 nil)
    (alert "\n No TEXT selected")
    (setq en1 (entsel "\n Select the TEXT to write under - "))	
  );end of while
 
  (setq en2 (car en1))
  (setq en3 (entget en2))

;;;CHECK TO SEE IF TEXT OR MTEXT

  (setq type1 (cdr (assoc 0 en3)))
  (if (= type1 "MTEXT")
    (command "DDEDIT" en1 "")
    (textun)
  )
	
;;;RESET EXISTING VALUES

; (setvar "TEXTSIZE" size1)
; (setvar "TEXTSTYLE" style1)
; (setvar "CLAYER" layer1)
; (setvar "CECOLOR" col2)

  (setvar "cmdecho" 1)
  (LM:endundo (LM:acdoc))
  (princ)
)

(defun c:LH (/ *error* lll osm edp mspace mtext vta tbmtext midpt  )
  (setvar "cmdecho" 0)
  (LM:startundo (LM:acdoc))
  ;error control
    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\n Error: " msg))
        )
        (setvar "cmdecho" 1)
        (princ)
    )

  (graphscr)

  (setq lll (getvar "clayer"))
  (setq osm (getvar "osmode"))
  (command "OSNAP" "INTERSECTION")
  (command "layer" "m" "GTEXT" "")

  (setq edp (getpoint "\n pick point for Loft Hatch - "))
  ;(command "MTEXT" edp "_Justify" "MC" "_none" "@" "Loft" "hatch" "")

  (setq mspace (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))  
  (setq mtext (vla-AddMText mspace (vlax-3d-point (trans edp 1 0)) 0 "Loft\nHatch"))
  
  (setvar "OSMODE" osm)
  (command "LAYER" "S" lll "")

  (setq vta (- 0 (getvar "viewtwist")))
 
  (vla-put-rotation mtext vta)
  (vla-put-AttachmentPoint mtext acBottomCenter)

  (setq tbmtext (LM:textbox (entget (vlax-vla-object->ename mtext))))
  (setq midpt (mid (car tbmtext) (caddr tbmtext)) )

  (vla-move mtext (vlax-3d-point midpt) (vlax-3d-point edp))

  (setvar "cmdecho" 1)
  (LM:endundo (LM:acdoc))
  (princ)
)




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


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



;; Text Box  -  Lee Mac (based on code by gile)
;; Returns the bounding box of a text, mtext, or attribute entity (in OCS)
;; enx - [lst] Text, MText or Attribute DXF data list

(defun LM:textbox ( enx / bpt hgt jus lst ocs org rot wid )
    (cond
        (   (and (= "ATTRIB" (cdr (assoc 000 enx)))
                 (= "Embedded Object" (cdr (assoc 101 enx)))
            )
            (LM:textbox (cons '(000 . "MTEXT") (member '(101 . "Embedded Object") enx)))
        )
        (   (cond
                (   (wcmatch  (cdr (assoc 000 enx)) "ATTRIB,TEXT")
                    (setq bpt (cdr (assoc 010 enx))
                          rot (cdr (assoc 050 enx))
                          lst (textbox enx)
                          lst (list (car lst) (list (caadr lst) (cadar lst)) (cadr lst) (list (caar lst) (cadadr lst)))
                    )
                )
                (   (= "MTEXT" (cdr (assoc 000 enx)))
                    (setq ocs  (cdr (assoc 210 enx))
                          bpt  (trans (cdr (assoc 010 enx)) 0 ocs)
                          rot  (angle '(0.0 0.0) (trans (cdr (assoc 011 enx)) 0 ocs))
                          wid  (cdr (assoc 042 enx))
                          hgt  (cdr (assoc 043 enx))
                          jus  (cdr (assoc 071 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 org (mapcar '+ org (list wid 0)) (mapcar '+ org (list wid hgt)) (mapcar '+ org (list 0 hgt)))
                    )
                )
            )
            (   (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)
                )
            )
        )
    )
)


(princ "\n loading complete")

LH's steps are as follows:

1. Create an mtext at the specified point.

In this case, the automatically selected MTEXT insertion point is upper left.

2. Rotate by "0 - viewtwist value" to compensate the viewtwist value.

3. Change the attachment point to bottom center.

At this point, the position of the text is changed.

(not like TJUST command)

4. Find the midpoint of the mtext and move the mtext

from midpoint to the specified point step1

without changing the attachment point property.

If any of these steps are incorrect, you can correct them.

+

Line spacing between texts in TT and UT

is changed by modifying "1.5" of "(* textsize 1.5)."

Edited March 21, 2022 by exceed

March 22, 2022

Thank you exceed for all your work. TT and UT are both working fine now. I'll check out your latest combined code later (busy with getting some actual work done at the moment).

Thanks again.

Sign In

Lisp routines to insert text fail in UCS

Recommended Posts

anivegmin

Link to comment

Share on other sites

anivegmin

Link to comment

Share on other sites

mhupp

Link to comment

Share on other sites

anivegmin

Link to comment

Share on other sites

exceed

Link to comment

Share on other sites

anivegmin

Link to comment

Share on other sites

exceed

Link to comment

Share on other sites

anivegmin

Link to comment

Share on other sites

exceed

Link to comment

Share on other sites

anivegmin

Link to comment

Share on other sites

Join the conversation

Tutorials

Forums

Activity