;;;д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,;;; ;;;°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,д║░`░║д;;; ;; ;; ;; --=={ Text 2 MText Upgraded }==-- ;; ;; ;; ;; Similar to the Txt2MTxt Express Tools function, but allows the user ;; ;; additional control over where the text is placed in the resultant MText. ;; ;; ;; ;; The user can pick MText or DText, positioning such text using one of two ;; ;; modes: "New Line" or "Same Line". The Modes can be switched by pressing ;; ;; Space between picks. ;; ;; ;; ;; The user can also hold shift and pick text to keep the original text in ;; ;; place, and press "u" between picks to undo the last text pick. ;; ;; ;; ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;; ;; ;; ;; FUNCTION SYNTAX: T2M ;; ;; ;; ;; Notes:- ;; ;; -------- ;; ;; Shift-click functionality requires the user to have Express Tools installed. ;; ;; ;; ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;; ;; ;; ;; AUTHOR: ;; ;; ;; ;; Copyright й Lee McDonnell, September 2009. All Rights Reserved. ;; ;; ;; ;; { Contact: Lee Mac @ TheSwamp.org, CADTutor.net } ;; ;; ;; ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;; ;; ;; ;; VERSION: ;; ;; ;; ;; ° 1.0 ~д~ 27th September 2009 ~д~ ║ First Release ;; ;;...............................................................................;; ;; ° 1.1 ~д~ 29th September 2009 ~д~ ║ Minor Bug Fixes ;; ;;...............................................................................;; ;; ° 1.2 ~д~ 29th September 2009 ~д~ ║ Fixed Alignment Bug ;; ;; ║ Added Code to match Height ;; ;;...............................................................................;; ;; ° 1.3 ~д~ 1st October 2009 ~д~ ║ Added option to Copy Text. ;; ;;...............................................................................;; ;; ° 1.4 ~д~ 1st October 2009 ~д~ ║ Added option to Undo Last text ;; ;; Selection ;; ;;...............................................................................;; ;; ° 1.5 ~д~ 30th March 2010 ~д~ ║ Modified code to allow for ;; ;; mis-click. ;; ;; ║ Updated UndoMarks. ;; ;;...............................................................................;; ;; ° 1.6 ~д~ 15th April 2010 ~д~ ║ MText objects now have correct ;; ;; width. ;; ;; ║ Accounted for %%U symbol. ;; ;;...............................................................................;; ;; ° 1.7 ~д~ 16th April 2010 ~д~ ║ Fixed %%U bug. ;; ;; ║ Trimmed Spaces when in ;; ;; 'Same Line' mode. ;; ;; ║ Fixed Width when Undo is used. ;; ;; ║ Allowed Shift-Click to keep ;; ;; first text object selected. ;; ;;...............................................................................;; ;; ;; ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;; ;; ;; ;;;д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,;;; ;;;°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,д║░`░║д;;; (defun c:t2m ( / ;; -={ Local Functions }=- *error* align_Mt Get_MTOffset_pt GetTextWidth ReplaceUnderline ;; -={ Local Variables }=- CODE DATA DOC ELST ENT ET FORMFLAG GRDATA LHGT LLST MLST MSG NOBJ NSTR OBJ SHFT SPC TENT TOBJ UFLAG UNDER WLST ;; -={ Global Variables }=- ; *T2M_mode* ~ Mode for line addition ) (vl-load-com) ;;;д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕ ; --=={ Sub Functions }==-- ; ;;;д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕ ;; -={ Error Handler }=- (defun *error* (err) (and uFlag (vla-EndUndoMark doc)) (and tObj (not (vlax-erased-p tObj)) (vla-delete tObj)) (if eLst (mapcar (function entdel) (vl-remove-if (function null) eLst))) (or (wcmatch (strcase err) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\n** Error: " err " **"))) (princ)) (defun align_Mt (obj / al) (cond ( (eq "AcDbMText" (vla-get-ObjectName obj)) (vla-get-AttachmentPoint obj)) ( (eq "AcDbText" (vla-get-ObjectName obj)) (setq al (vla-get-Alignment obj)) (cond ( (<= 0 al 2) (1+ al)) ( (<= 3 al 5) 1) (t (- al 5)))))) (defun Get_MTOffset_pt (obj pt / miP maP al) (vla-getBoundingBox obj 'miP 'maP) (setq miP (vlax-safearray->list miP) maP (vlax-safearray->list maP)) (setq al (vla-get-AttachmentPoint obj)) (cond ( (or (eq acAttachmentPointTopLeft al) (eq acAttachmentPointTopCenter al) (eq acAttachmentPointTopRight al)) (polar pt (/ (* 3 pi) 2.) (vla-get-Height obj))) ( (or (eq acAttachmentPointMiddleLeft al) (eq acAttachmentPointMiddleCenter al) (eq acAttachmentPointMiddleRight al)) (polar pt (/ (* 3 pi) 2.) (+ (vla-get-Height obj) (/ (- (cadr maP) (cadr miP)) 2.)))) ( (or (eq acAttachmentPointBottomLeft al) (eq acAttachmentPointBottomCenter al) (eq acAttachmentPointBottomRight al)) (polar pt (/ (* 3 pi) 2.) (+ (vla-get-Height obj) (- (cadr maP) (cadr miP))))))) (defun GetTextWidth (obj / tBox eLst) (cond ( (eq "AcDbText" (vla-get-objectname obj)) (setq eLst (entget (vlax-vla-object->ename obj)) tBox (textbox (subst (cons 1 (strcat "..." (cdr (assoc 1 eLst)))) (assoc 1 eLst) eLst))) (- (caadr tBox) (caar tBox))) ( (vla-get-Width obj)))) (defun ReplaceUnderline (str / i under) (if (vl-string-search "%%U" (strcase Str)) (progn (while (and (< i (strlen Str)) (setq i (vl-string-search "%%U" (strcase Str) i))) (if under (setq Str (strcat (substr Str 1 i) "\\l" (substr Str (+ i 4))) i (+ i 4) under nil) (setq Str (strcat (substr Str 1 i) "\\L" (substr Str (+ i 4))) i (+ i 4) under t ))) (if under (setq str (strcat str "\\l"))))) str) ;;;д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕ ; --=={ Main Function }==-- ;;;д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕ (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)) spc (if (or (eq AcModelSpace (vla-get-activespace doc)) (eq :vlax-true (vla-get-MSpace doc))) (vla-get-modelspace doc) (vla-get-paperspace doc))) (setq Et (and (vl-position "acetutil.arx" (arx)) (not (vl-catch-all-error-p (vl-catch-all-apply (function (lambda nil (acet-sys-shift-down)))))))) (or *T2M_Mode* (setq *T2M_Mode* 0)) (setq mLst '("New Line " "Same Line")) (while (progn (setq ent (car (entsel "\nSelect Text/MText [Shift-Click keep original]: "))) (and et (setq shft (acet-sys-shift-down))) (cond ( (not ent) (princ "\n** Nothing Selected **")) ( (not (wcmatch (cdr (assoc 0 (entget ent))) "*TEXT")) (princ "\n** Object is not Text **"))))) (setq uFlag (not (vla-StartUndoMark doc))) (setq tObj (vla-AddMText spc (vla-get-InsertionPoint (setq obj (vlax-ename->vla-object ent))) (GetTextWidth obj) (ReplaceUnderline (vla-get-TextString obj)))) (foreach p '(InsertionPoint Layer Color StyleName Height) (vlax-put-property tObj p (vlax-get-property obj p))) (vla-put-AttachmentPoint tObj (align_Mt obj)) (or (and shft (setq eLst (cons nil eLst))) (and (entdel ent) (setq eLst (cons ent eLst)))) (princ (eval (setq msg '(strcat "\n~д~ Current Mode: " (nth *T2M_mode* mLst) " ~д~ [Space to Change]" "\n~д~ Select Text to Convert [Shift-Click keep original] [Undo] <Place MText> ~д~")))) (while (progn (setq grdata (grread 't 15 2) code (car grdata) data (cadr grdata)) (cond ( (and (= 5 code) (listp data)) (vla-put-InsertionPoint tObj (vlax-3D-point (Get_MTOffset_pt tObj data))) t) ( (and (= 3 code) (listp data)) (if (and (setq tEnt (car (nentselp data))) (wcmatch (cdr (assoc 0 (entget tEnt))) "*TEXT")) (progn (setq lLst (cons (strlen (vla-get-TextString tObj)) lLst) wLst (cons (vla-get-Width tObj) wLst)) (setq nStr (vla-get-TextString (setq nObj (vlax-ename->vla-object tEnt))) formflag nil) (vla-put-Width tObj ((if (= *T2M_mode* 1) + max) (vla-get-Width tObj) (GetTextWidth nObj))) (if (not (or (eq (vla-get-Color nObj) (vla-get-Color tObj)) (vl-position (vla-get-Color nObj) '(255 0)))) (setq nStr (strcat "\\C" (itoa (vla-get-Color nObj)) ";" nStr) formflag t)) (setq nStr (ReplaceUnderline nStr)) (if (not (or (eq (vla-get-Height nObj) (vla-get-Height tObj)) (and lHgt (eq (vla-get-Height nObj) lHgt)))) (setq nStr (strcat "\\H" (rtos (/ (float (vla-get-Height nObj)) (cond (lHgt) ((vla-get-Height tObj)))) 2 2) "x;" nStr) lHgt (vla-get-Height nObj) formflag t)) (if (not (eq (vla-get-StyleName nObj) (vla-get-StyleName tObj))) (setq nStr (strcat "\\F" (vla-get-fontfile (vla-item (vla-get-TextStyles doc) (vla-get-StyleName nObj))) ";" nStr) formflag t)) (if formflag (setq nStr (strcat "{" nStr "}"))) (vla-put-TextString tObj (strcat (vla-get-TextString tObj) (if (zerop *T2M_mode*) (strcat "\\P" nStr) (strcat " " (vl-string-left-trim (chr 32) nStr))))) (vla-update tObj) (or (and et (acet-sys-shift-down) (setq eLst (cons nil eLst))) (and (entdel tEnt) (setq eLst (cons tEnt eLst)))) t) (princ (strcat "\n** No Text/MText Selected **" (eval msg))))) ( (= 25 code) nil) ( (= 2 code) (cond ( (= 13 data) nil) ( (= 32 data) (setq *T2M_mode* (- 1 *T2M_mode*)) (princ (eval msg))) ( (vl-position data '(85 117)) (if (< 1 (length eLst)) (progn (vla-put-TextString tObj (substr (vla-get-TextString tObj) 1 (car lLst))) (vla-put-Width tObj (car wLst)) (if (car eLst) (entdel (car eLst))) (setq eLst (cdr eLst) lLst (cdr lLst) wLst (cdr wLst)) t) (progn (princ "\n** Nothing to Undo **") (princ (eval msg))))) (t ))) (t )))) (setq uFlag (vla-EndUndoMark doc)) (princ)) (princ "\n°д║░`░║д° Text2MText.lsp ~ Copyright й by Lee McDonnell °д║░`░║д°") (princ "\n ~д~ ...Type \"T2M\" to Invoke... ~д~ ") (princ) ;;;д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,;;; ;; ;; ;; End of Program Code ;; ;; ;; ;;;°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,д║░`░║д;;; |