Transform co-ordinates of vertices to work with entmake

[dlbsurveysuk]

I've just rewritten some lisp routines that were annoyingly laggy, to use entmake instead of autocad commands. It has cured the laggyness. The routines include some simple trans commands to allow them to work in a UCS where the x,y plane is rotated around the z axis.

Attached example-LP-routines

I don't really understand these lines - (setq NORMAL (trans '(0.0 0.0 1.0) 2 0 T)) and (cons 50 (angle '(0.0 0.0 0.0) (trans '(1.0 0.0 0.0) 2 NORMAL T))) but they work ...

In another routine I'm now trying to entmake a 4 point closed polyline (rectangle) that is based upon the 2 points of a textbox, in a UCS created as follows -

WCS is rotated some amount in the x,y plane around the z axis.
UCS is set to view.
UCS is then rotated -90 degrees around the x axis and a new UCS is set.

The routine in it's current form using autocad commands works fine in the above UCS settings, but I'd like to convert it to using entmake, and I can't figure out what trans coding I need to use.

Routine attached in it's current working form with the possible entmake part currently commented out (arrow-down-annotated).

Thanks for any help.

[john.uhden]

@dlbsurveysuk ,

I might actually be right on this.

Suppose your UCS is twisted, and you get a point (pu) while that way.

To transform that point to WCS, then just (setq pw (trans pu 1 0)).

If you have a list of points you want to transform, e.g. (setq ucslist (list p1 p2 p3 p4)), then

(setq wlist (mapcar '(lambda (p)(trans p 1 0)) ucslist))).

You can do the reverse as well with (trans p 0 1).

[dlbsurveysuk]

Yes I know the basic operation of trans and have tried  (trans ....... 1 0) on all the PTB and PTF points but it doesn't work. I think it might be something to do with the textbox co-ordinates  LL and UR but I can't figure it out.

[john.uhden]

@dlbsurveysuk ,

I guess I missed something.  What does textbox have to do with this?

AFAIK the textbox function returns the coordinates of the lower left corner and upper right corner of a TEXT object only and the coordinates are not related to any UCS.  They actually represent a relationship to simply derive the width and height.

[dlbsurveysuk]

OK, thanks. I think I was misinterpreting what the returned textbox co-ordinates actually were.

Anyway, I've just found Lee Mac's Box Text routine that works in any UCS, so I 'm gonna try and extract the relevant portions of code. 

[komondormrex · Accepted solution]

maybe you ought to pay attention to drawing mtext with its background fill switched on instead of trimming pline on the textbox borders?

[dlbsurveysuk]

A lot of the text routines I have are from when I worked for another company, they are quite old and were written by someone else, I've just kept using them. They were all written using ordinary text.  I have converted the original multi line tree labelling routine to MTEXT, I really should do all the rest.

[dlbsurveysuk]

OK. I've converted all possibilities to entmake  and used mtext with background mask instead of trimming a pline around text. With zero autocad commands in the code it's definitely faster now.

One thing with mtext and the background mask is that visually in modelspace it shows weird behaviour at different pans and zooms and the mask is always visible (see attached images). When trimming a pline around text you get visually what is actually happening. I tried using Lee Mac's Background Mask routine but to no avail... It's a bit annoying for me. Is this common behaviour?

Thanks.

(defun c:CLGO (/)
   (setq ANNOT "Clg Dn")
   (CLGOHV ANNOT)
(princ)
)

(defun c:SDO (/)
   (setq ANNOT "Slates Down")
   (CLGOHV ANNOT)
(princ)
)

(defun c:TDO (/)
   (setq ANNOT "Tiles Down")
   (CLGOHV ANNOT)
(princ)
)

;**********************************************************************************************

;; Intersections  -  Lee Mac
;; Returns a list of all points of intersection between two objects
;; for the given intersection mode.
;; ob1,ob2 - [vLa] VLA-Objects
;; mod - [int] acextendoption enum of intersectwith method

(defun LM:intersections ( ob1 ob2 mod / Lst rtn )
    (if (and (vlax-method-applicable-p ob1 'intersectwith)
             (vlax-method-applicable-p ob2 'intersectwith)
             (setq Lst (vlax-invoke ob1 'intersectwith ob2 mod))
        )
        (repeat (/ (length Lst) 3)
            (setq rtn (cons (list (car Lst) (cadr Lst) (caddr Lst)) rtn)
                  Lst (cdddr Lst))))
    (reverse rtn)
)

;***********************************************************************************************

(defun CLGOHV (ANNOT / acadObj doc osm Lyr ts f s o e x L an a pdt pt tbe trimfact textent PTB1 PTB2 PTB3 PTB4 PTF1 PTF3 PTF4 PTF1)

  (vl-load-com)
  (setq acadObj (vlax-get-acad-object))
  (setq doc (vla-get-ActiveDocument acadObj))
  (vla-StartUndoMark doc)

           (defun *error* (MSG)
            (if (/= MSG "Function cancelled")
                (princ (strcat "\nError: " MSG)))
              (if osm (setvar 'osmode OSM))
              (if orm (setvar 'orthomode ORM))
          (princ))

    (setvar 'cmdecho 0)
    (setvar 'orthomode 1)
    (setvar 'osmode 512)
  
    (setq TS (getvar 'textsize)
    	  OSM (getvar 'osmode)
    	  ORM (getvar 'orthomode))

     (if (null global:ans)
         (setq global:ans "V")
     )

     (initget "H V")
     (if (setq tmp (getkword (strcat "\nHorizontal or vertical? [H/V] <" global:ans ">: ")))
         (setq global:ans tmp)
     )

       (if (= global:ans "V")
         (progn
              (setq F (getpoint "Tip of arrow: "))
              (setq S (getpoint f "End of arrow: "))

             (setvar 'osmode 0)
              (setq O (car (nentseLp S)))
              (command "Line" F (polar F (/ pi 2) 1) "")
         )
         (progn
              (setq F (getpoint "Tip of arrow: "))
              (setq S (getpoint f "End of arrow: "))

              (setvar 'osmode 0)
              (setq O (car (nentseLp S)))

              (entmake
                (list
                  '(0 . "LINE")
                  '(8 . "GTEXT")
                   (cons 10 (trans F 1 0))
                   (cons 11 (trans (polar F pi 1) 1 0))
                )
              )
         )
      )
         (setq E (entLast))
          (setq XorY (trans (car (LM:intersections (vlax-ename->vLa-object E) (vlax-ename->vLa-object O) acextendthisentity)) 0 1))
         (entdel e)

     (setq L (distance F XorY)
	   AN (angle F XorY)
	   pdt (/ L 2)
	   pt (polar F AN pdt))

 	 (entmake
              (list
                '(0 . "LINE")
                '(8 . "GTEXT")
                 (cons 10 (trans F 1 0))
                 (cons 11 (trans XorY 1 0))
              )
         )
         (entmake
           (list
              '(0 . "INSERT") '(8 . "GTEXT") '(2 . "arhead") (cons 10 F)
               (cons 50 AN)
               (cons 210 (trans '(0 0 1) 1 0 t))
               (cons 41 TS) (cons 42 TS) (cons 43 TS)
           )
         )
	 (entmake
           (list
              '(0 . "MTEXT")
              '(100 . "AcDbEntity")
              '(100 . "AcDbMText")
              '(1 . "")
               (cons 1 ANNOT)
               (cons 7 (getvar 'textstyle))	      
              '(8 . "GTEXT")
               (cons 10 (trans pt 1 0))
               (cons 11 (getvar 'ucsxdir))
               (cons 40 ts)
               (cons 210 (trans '(0 0 1) 1 0 t))
              '(71 . 5) '(72 . 5)                            ;justify
              '(90 . 1) '(63 . 😎 '(45 . 1.1) '(441 . 0)     ;background mask
           )
         )

   (setvar 'osmode OSM)
   (setvar 'orthomode ORM)
  
(vla-EndUndoMark doc)
(princ)
)

[komondormrex]

no image attached and there is also unfinished 63 group dotted pair in mtext entmake.

[dlbsurveysuk]

oops

[komondormrex]

i would recommend you to switch the background mask on for mtext to default drawing background color with 

(vlax-put mtext_object 'backgroundfill 1)

[ВeekeeCZ]

Wrong parents here

'(90 . 1) '(63 .  '(45 . 1.1) '(441 . 0) 

[dlbsurveysuk]

Thanks for all the notes. All good points. Much appreciated.

[dlbsurveysuk]

Have I implemented your code correctly ? I've tried both backgroundfill lines.

It doesn't seem to have changed anything...

Thanks.

(defun c:CLGO (/)
   (CLGOHV "Clg Dn")
(princ)
)

(defun c:SDO (/)
   (CLGOHV "Slates Down")
(princ)
)

(defun c:TDO (/)
   (CLGOHV "Tiles Down")
(princ)
)

;**********************************************************************************************

;; Intersections  -  Lee Mac
;; Returns a list of all points of intersection between two objects
;; for the given intersection mode.
;; ob1,ob2 - [vLa] VLA-Objects
;; mod - [int] acextendoption enum of intersectwith method

(defun LM:intersections ( ob1 ob2 mod / Lst rtn )
    (if (and (vlax-method-applicable-p ob1 'intersectwith)
             (vlax-method-applicable-p ob2 'intersectwith)
             (setq Lst (vlax-invoke ob1 'intersectwith ob2 mod))
        )
        (repeat (/ (length Lst) 3)
            (setq rtn (cons (list (car Lst) (cadr Lst) (caddr Lst)) rtn)
                  Lst (cdddr Lst))))
    (reverse rtn)
)

;***********************************************************************************************

(defun CLGOHV (ANNOT / *error* acadObj doc osm Lyr ts f s o e x L an a pdt pt tbe trimfact textent PTB1 PTB2 PTB3 PTB4 PTF1 PTF3 PTF4 PTF1)

  (vl-load-com)
  (setq acadObj (vlax-get-acad-object))
  (setq doc (vla-get-ActiveDocument acadObj))
  (vla-StartUndoMark doc)

           (defun *error* (MSG)
            (if (/= MSG "Function cancelled")
                (princ (strcat "\nError: " MSG)))
              (if osm (setvar 'osmode OSM))
              (if orm (setvar 'orthomode ORM))
              (if ceo (setvar 'cmdecho CEO))
          (princ))

         (setq TS (getvar 'textsize)
   	  OSM (getvar 'osmode)
    	  ORM (getvar 'orthomode)
                 CEO (getvar 'cmdecho))

    (setvar 'cmdecho 0)
    (setvar 'orthomode 1)
    (setvar 'osmode 512)
  
     (if (null global:CLGOHV:dir)
         (setq global:CLGOHV:dir "V")
     )

     (initget "H V")
     (if (setq tmp (getkword (strcat "\nHorizontal or vertical? [H/V] <" global:CLGOHV:dir ">: ")))
         (setq global:CLGOHV:dir tmp)
     )

       (if (= global:CLGOHV:dir "V")
         (progn
              (setq F (getpoint "Tip of arrow: "))
              (setq S (getpoint f "End of arrow: "))

              (setq O (car (nentseLp S)))

              (entmake
                (list
                  '(0 . "LINE")
                  '(8 . "GTEXT")
                   (cons 10 (trans F 1 0))
                   (cons 11 (trans (polar F (/ pi 2) 1) 1 0))
                )
              )
         )
         (progn
              (setq F (getpoint "Tip of arrow: "))
              (setq S (getpoint f "End of arrow: "))

              (setq O (car (nentseLp S)))

              (entmake
                (list
                  '(0 . "LINE")
                  '(8 . "GTEXT")
                   (cons 10 (trans F 1 0))
                   (cons 11 (trans (polar F pi 1) 1 0))
                )
              )
         )
      )
         (setq E (entLast))
          (setq XorY (trans (car (LM:intersections (vlax-ename->vLa-object E) (vlax-ename->vLa-object O) acextendthisentity)) 0 1))
         (entdel e)

     (setq L (distance F XorY)
	   AN (angle F XorY)
	   pdt (/ L 2)
	   pt (polar F AN pdt))

 	 (entmake
              (list
                '(0 . "LINE")
                '(8 . "GTEXT")
                 (cons 10 (trans F 1 0))
                 (cons 11 (trans XorY 1 0))
              )
         )
         (entmake
           (list
              '(0 . "INSERT") '(8 . "GTEXT") '(2 . "arhead") (cons 10 F)
               (cons 50 AN)
               (cons 210 (trans '(0 0 1) 1 0 t))
               (cons 41 TS) (cons 42 TS) (cons 43 TS)
           )
         )
	 (entmake
           (list
              '(0 . "MTEXT")
              '(100 . "AcDbEntity")
              '(100 . "AcDbMText")
               (cons 1 ANNOT)
               (cons 7 (getvar 'textstyle))	      
              '(8 . "GTEXT")
               (cons 10 (trans pt 1 0))
               (cons 11 (getvar 'ucsxdir))
               (cons 40 ts)
               (cons 210 (trans '(0 0 1) 1 0 t))
              '(71 . 5) '(72 . 5)                            ;justify
              '(90 . 1) '(63 .  '(45 . 1.1) '(441 . 0)     ;background mask
           )
         )

           (setq obj (vlax-ename->vla-object (entlast)))

         (vlax-put-property obj 'BackgroundFill 1)   ;;;

;;;         (vlax-put obj 'backgroundfill 1)

   (setvar 'osmode OSM)
   (setvar 'orthomode ORM)
   (setvar 'cmdecho CEO)
  
(vla-EndUndoMark doc)
(princ)
)

[ВeekeeCZ]

No.

Why do you need that h/v prompt anyway? It should recognize the direction by two points given by the user. If dx>>dy, then draw a horizontal line.

[dlbsurveysuk]

Good point, that's so obvious now you've said it.

[komondormrex]

you need to remove line 140 to make it work

[Sea-Haven]

As above line 140 the '(63 does not have a value and no closing bracket need to check for that, may cause problem elsewhere once added.

[john.uhden]

@dlbsurveysuk ,

I also thought that including the codes in entmake would be successful, but it wasn't working.  It was still stuck at 1.5.  Last night I tried this on existing mtext...

(entmod (append ent '((90 . 3)(45 . 1.1))))

and it worked!

I sure hope it continues to work, and for everyone.

[dlbsurveysuk]

OK. I've messed around with the background mask settings for entmake (after thoroughly investigating the relevant DXF codes), and also manually tested some MTEXT, right clicking in the editor to get the background mask settings. Everything gives me the weird annoying behaviour I mentioned before.

I've gone back to using ordinary TEXT for this routine... Implemented most of the recommendations provided here, including using a dx dy comparison instead of a H/V choice, and borrowed various bits of code from Lee Mac's BoxTextV1-2.lsp.

So now I have a routine with all Autocad commands removed/replaced (apart from TRIM). Everything is working fine and a little more smoothly than originally.

Whether the small reduction in laggyness was worth all the time spent is another question.... Although hopefully I've learnt something.... (Get on with your work and stop messing around with ridiculous Lisp routines!)

(defun c:CLGO (/)
   (CLGOHV "Clg Dn")
(princ)
)

(defun c:SDO (/)
   (CLGOHV "Slates Down")
(princ)
)

(defun c:TDO (/)
   (CLGOHV "Tiles Down")
(princ)
)

;***********************************************************************************************

(defun CLGOHV (ANNOT / *error* acadObj doc osm ceo orm ts f s o e x L an a pdt pt pt2 tbe trimfact textent enx bx)

(vl-load-com)

(setq acadObj (vlax-get-acad-object))
(setq doc (vla-get-ActiveDocument acadObj))
(vla-StartUndoMark doc)

         (defun *error* (MSG)
            (if (/= MSG "Function cancelled")
                (princ (strcat "\nError: " MSG)))
              (if osm (setvar 'osmode OSM))
              (if orm (setvar 'orthomode ORM))
              (if ceo (setvar 'cmdecho CEO))
          (princ))

   (setq OSM (getvar 'osmode))
   (setq TS (getvar 'textsize))
   (setq ORM (getvar 'orthomode))

    (setvar 'cmdecho 0)
    (setvar 'orthomode 1)
    (setvar 'osmode 512)

              (setq F (getpoint "Tip of arrow: "))
              (setq S (getpoint f "End of arrow: "))
  
              (setq O (car (nentseLp S)))

              (if (< (abs (- (car F) (car S))) (abs (- (cadr F) (cadr S)))) 
                  (setq PT2 (trans (polar F (/ pi 2) 1) 1 0))
                  (setq PT2 (trans (polar F pi 1) 1 0))
               )

              (entmake
                (list
                  '(0 . "LINE")
                  '(8 . "GTEXT")
                   (cons 10 (trans F 1 0))
                   (cons 11 PT2)
                )
              )
  
         (setq E (entLast))
          (setq XorY (trans (car (LM:intersections (vlax-ename->vLa-object E) (vlax-ename->vLa-object O) acextendthisentity)) 0 1))
         (entdel e)

     (setq L (distance F XorY)
	   AN (angle F XorY)
	   A (* (/ AN pi) 180)
	   pdt (/ L 2)
	   pt (polar F AN pdt))

 	 (entmake
              (list
                '(0 . "LINE")
                '(8 . "GTEXT")
                 (cons 10 (trans F 1 0))
                 (cons 11 (trans XorY 1 0))
              )
         )
         (entmake
           (list
              '(0 . "INSERT") '(8 . "GTEXT") '(2 . "arhead") (cons 10 F)
               (cons 50 AN)
               (cons 210 (trans '(0 0 1) 1 0 t))
               (cons 41 TS) (cons 42 TS) (cons 43 TS)
           )
         )

        (entmake
          (list
             '(0 . "TEXT") '(8 . "GTEXT") (cons 40 Ts) (cons 41 0.875) (cons 1 annot) (cons 10 pt) (cons 11 pt)
             (cons 7 (getvar 'textstyle)) (cons 210 (trans '(0 0 1) 1 0 t))
              '(72 . 4)
          )   
        )

            (setq off 0.35)
            (setq enx (entget (entlast)))
            (setq lst (text-box-off enx (* off (cdr (assoc 40 enx)))))
  
            (entmake
                (append
                   '(
                        (000 . "LWPOLYLINE")
                        (100 . "AcDbEntity")
                        (100 . "AcDbPolyline")
                        (090 . 4)
                        (070 . 1)
                    )
                    (LM:defaultprops enx)
                    (list (cons  038 (caddar lst)))
                    (mapcar '(lambda ( x ) (cons 10 x)) lst)
                    (list (assoc 210 enx))
                )
            )

            (setq off 0.17)
            (setq lst (text-box-off enx (* off (cdr (assoc 40 enx)))))
               (setq BX (entlast))
                  (command "TRIM" BX "" "f" (nth 0 lst) (nth 1 lst) (nth 2 lst) (nth 3 lst) "" "")
               (entdel BX)

  (setvar 'osmode OSM)
  (setvar 'orthomode ORM)

(vla-EndUndoMark doc)
(princ)
)

;**********************************************************************************************

;; Intersections  -  Lee Mac
;; Returns a list of all points of intersection between two objects
;; for the given intersection mode.
;; ob1,ob2 - [vLa] VLA-Objects
;; mod - [int] acextendoption enum of intersectwith method

(defun LM:intersections ( ob1 ob2 mod / Lst rtn )
    (if (and (vlax-method-applicable-p ob1 'intersectwith)
             (vlax-method-applicable-p ob2 'intersectwith)
             (setq Lst (vlax-invoke ob1 'intersectwith ob2 mod))
        )
        (repeat (/ (length Lst) 3)
            (setq rtn (cons (list (car Lst) (cadr Lst) (caddr Lst)) rtn)
                  Lst (cdddr Lst))))
    (reverse rtn)
)

;**************************************************************************************

;; Default Properties  -  Lee Mac
;; Returns a list of DXF properties for the supplied DXF data,
;; substituting default values for absent DXF groups
 
(defun LM:defaultprops ( enx )
    (mapcar '(lambda ( x ) (cond ((assoc (car x) enx)) ( x )))
       '(
            (006 . "BYLAYER")
            (008 . "0")
            (039 . 0.0)
            (048 . 1.0)
            (062 . 256)
            (370 . -1)
        )
    )
)

;**************************************************************************************

 (defun text-box-off ( enx off / bpt hgt jus lst ocs org rot wid )


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

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

;***************************************************************************************

;; Matrix x Vector  -  Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n
 
(defun mxv ( m v )
    (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)

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

;*********************************************************************************************************