Topic: Polyligne over a mtext or a dtext

[fabcad]

Hello everyone,
I would like a function that would create a polyline with the angle and length of a text or mtext.
Thank you.

[Brick_top]

Hi there... not quite this, but it's the best I could do... I'm a beginner 

Code: [Select]

(defun rpg (a)
(* a (/ 180.0 pi))
)
(defun gpr (a)
  (* pi (/ a 180.0))
)
(defun c:lot ()
  (setq t1 (entget (car (entsel "\nSelect text Object: ")))
tc (textbox (list (assoc 1 t1)))
ti (cdr (assoc 10 t1))
th (/ (cdr (assoc 40 t1)) 2)
ta (rpg (cdr (assoc 50 t1)))
nc (mapcar '(lambda (x) (list (+ (car x)(car ti))(+ (cadr x)(cadr ti)))) tc)
nc1 (polar (car nc) (gpr (+ 90.0 ta)) th)
nc2 (polar (cadr nc) (gpr (- 90.0 ta)) th)
nd (distance nc1 nc2)
nnf (polar nc1 (cdr (assoc 50 t1)) nd)
  );setq
 (entmake (list (cons 0 "line")(cons 10 nc1)(cons 11 nnf)))
);defun

[Tharwat]

Check this out Buddy .

It is for dtext only and I could make it with Mtext but it is a matter of time only .

Code: [Select]

(defun C:Test (/ ss)
 ; Tharwat
  (prompt "\nSelect texts: ")
  (if (setq ss (ssget "_:L" '((0 . "TEXT"))))
    ((lambda (i / ent e aa ab ac p1 p2)
       (while (setq ent (ssname ss (setq i (1+ i))))
         (setq h (cdr (assoc 40 (entget ent))))
         (setq e (textbox (list
                            (cons -1 ent)
                          )
                 )
         )
         (command "ucs" "Object" ent)
         (setq aa (car e)
               ab (cadr e)
               ac (list (car ab) (cadr aa))
         )
         (command "_.pline"
                  "_non"
                  (setq p1 (list (car aa) (+ (cadr aa) (/ h 2))))
                  "_non"
                  (setq p2 (list (car ac) (+ (cadr ac) (/ h 2))))
                  ""
         )
         (command "_.ucs" "_p")

       )
     )
      -1
    )
    (alert "No TEXT(s) selected")
  )
  (princ)
)


[Lee Mac]

This will only work with Single-Line Text or MText with a Single Line, but will work in all UCS/Views:

Code: [Select]

(defun c:test ( / ss i e l )

  (if (setq ss (ssget '((0 . "TEXT,MTEXT"))))
    (repeat (setq i (sslength ss))

      (setq e (ssname ss (setq i (1- i)))
            l (entget e)
      )
      (entmakex
        (append
          (list
            (cons 0 "LWPOLYLINE")
            (cons 100 "AcDbEntity")
            (cons 100 "AcDbPolyline")
            (assoc 8 l)
            (cons 90 4)
            (cons 70 1)
            (cons 38 (caddr (cdr (assoc 10 l))))
            (assoc 210 l)
          )
          (mapcar '(lambda ( x ) (cons 10 x)) (LM:Strikethrough e))
        )
      )
    )
  )

  (princ)
)


(defun LM:Strikethrough ( e / dx a b h l m n o p r tb w y )
  ;; © Lee Mac 2011

  (defun dx ( x l ) (cdr (assoc x l)))

  (if
    (setq l
      (cond
        (
          (eq "TEXT" (dx 0 (setq e (entget e))))

          (setq b  (dx 10 e)
                r  (dx 50 e)
                tb (textbox e)
                y  (/ (+ (cadar tb) (cadadr tb)) 2.)
          )       
          (list (list (caar  tb) y) (list (caadr tb) y))
        )
        (
          (eq "MTEXT" (dx 0 e))

          (setq n (dx 210 e)
                b (trans (dx 10 e) 0 n)
                r (angle '(0. 0. 0.) (trans (dx 11 e) 0 n))
                w (dx 42 e)
                h (dx 43 e)
                a (dx 71 e)
          )
          (setq h
            (cond
              ( (member a '(1 2 3)) (/ h -2.) )
              ( (member a '(4 5 6)) 0. )
              ( (/ h 2.) )
            )
          )
          (setq o
            (cond
              ( (member a '(2 5 8)) (/ w -2.) )
              ( (member a '(3 6 9)) (- w) )
              ( 0. )
            )
          )
          (list (list o h) (list (+ o w) h))
        )
      )
    )
    (progn
      (setq m
        (list
          (list (cos r) (sin (- r)) 0.)
          (list (sin r) (cos    r)  0.)
          (list   0.        0.      1.)
        )
        b (reverse (cdr (reverse b)))
      )
      (mapcar
        (function
          (lambda ( p )
            (mapcar '+
              (mapcar
                (function
                  (lambda ( x ) (apply '+ (mapcar '* x p)))
                )
                m
              )
              b
            )
          )
        )
        l
      )
    )
  )
)

[fabcad]

Thank you,
Unfortunately, the first functions do not work in my AutoCAD MAP 3D 2009.

Thank you Lee Mac

Your function works well with both types of texts.

This website is really good, for being French, insert pictures are very helpful to understanding.

Good day

See you soon.

[Lee Mac]

You're very welcome (de rien) fabcad, enjoy

[Tharwat]

*cough* .... *cough*

[CAB]

That's a winner Lee.

[Lee Mac]

That's a winner Lee.

Thanks Alan 

[alanjt]

Very nice Lee. I needed the same thing one day a while back and quickly wrote this one, but I'll be replacing it with yours in case I need it again.

Code: [Select]

(defun c:STR (/ foo ss r)
  ;; Strike through MText/Text (draw line through middle of selected text objects)
  ;; Alan J. Thompson, 09.20.10

  (defun foo (o / a b)
    (vla-getboundingbox o 'a 'b)
    (mapcar 'set '(a b) (mapcar 'vlax-safearray->list (list a b)))
    (list o
          (vlax-ename->vla-object
            (entmakex (list '(0 . "LINE")
                            (list 10 (car a) (/ (+ (cadr a) (cadr b)) 2.))
                            (list 11 (car b) (/ (+ (cadr a) (cadr b)) 2.))
                      )
            )
          )
    )
  )

  (if (setq ss (ssget "_:L" '((0 . "MTEXT,TEXT"))))
    (progn
      (vlax-for x (setq ss (vla-get-activeselectionset
                             (cond (*AcadDoc*)
                                   ((setq *AcadDoc* (vla-get-activedocument
                                                      (vlax-get-acad-object)
                                                    )
                                    )
                                   )
                             )
                           )
                  )
        (setq r (vla-get-rotation x))
        (vla-put-rotation x 0.)
        (foreach i (foo x) (vla-rotate i (vla-get-insertionpoint x) r))
      )
      (vla-delete ss)
    )
  )
  (princ)
)

[Lee Mac]

Nice one Alan 

[alanjt]

Nice one Alan 

Thanks. Mine gets hosed if the text has a crazy width. I use a zero width for all text, unless I'm typing notes in paperspace, so I didn't think of that. I like yours a lot more.
I actually use this macro to place MText so I can easily get MText with a zero width:

Code: [Select]

; mtext with 0 width
(defun c:T (/ pt)
  (initdia)
  (command "_.mtext")
  (if (setq pt (getpoint "\nSpecify insertion point <First corner>: "))
    (command "_non" pt "_W" 0.)
  )
  (princ)
)

[Lee Mac]

Nice one Alan 

Thanks. Mine gets hosed if the text has a crazy width. I use a zero width for all text, unless I'm typing notes in paperspace, so I didn't think of that. I like yours a lot more.
I actually use this macro to place MText so I can easily get MText with a zero width.

Good idea - zero-width MText is much tidier IMO and that macro saves having to draw the MText window.

HTH

[alanjt]

Nice one Alan 

Thanks. Mine gets hosed if the text has a crazy width. I use a zero width for all text, unless I'm typing notes in paperspace, so I didn't think of that. I like yours a lot more.
I actually use this macro to place MText so I can easily get MText with a zero width.

Good idea - zero-width MText is much tidier IMO and that macro saves having to draw the MText window.

HTH

Thanky Thanky. If you notice, it will continue with normal MText behavior if you right-click when prompted fro insertion point - for those time I'm placing notes in paperspace. 

[Lee Mac]

 :kewl: