Mushroomer Цитата: Может ли кто-нибудь написать макрос, который циклически работает, но немного по-другому: каждый однострочный текст становится однострочным МТЕКСТ.
Немного не то, но можно попробовать этот [more=lisp]
Код: ;;;д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,;;;
;;;°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,д║░`░║д;;;
;; ;;
;; --=={ 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 ;;
;; ;;
;;;°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,°д║░`░║д°,╕╕,д║░`░║д;;;
И так далее.