;批量单行文字转多行文字[SL_TextToMtext].lsp
;迷你修改版
;; By Joe Burke

;; First version of TextToMtext v1.lsp posted at theswamp 11/25/2011.
;; Please send bug reports to me directly at lowercase@hawaii.rr.com
;; or post to the TextToMtext topic at theswamp under "Show your stuff".

;; General notes:

  ;; This routine is intended to be a modernized version the ExpressTools
  ;; txt2mtxt routine. It offers additional options and expanded formatting
  ;; support. These features are detailed below. It also supports tranfer of
  ;; fields from text objects to an mtext object in ACAD versions 2005 or
  ;; later, which support fields.

  ;; The routine was tested with ACAD versions 2000i, 2005, 2008 and 2010.
  ;; See notes below regarding some formatting codes which are not available
  ;; in versions prior to 2006.

  ;; Text objects on locked layers are ignored. The routine stops if all
  ;; selected text objects are on locked layers and the following message
  ;; is presented at the command line:
  ;; All objects are on locked layers or incorrect object type.

  ;; The routine allows pre-selection of text objects if the pickfirst
  ;; system variable is set to 1, the default setting. Otherwise,
  ;; pre-selected text objects are deselected.

  ;; The options at the command line vary when text objects are pre-selected
  ;; or not. When text objects are not pre-selected the command line prompt is:
  ;; "Select text objects or Enter for <Options>:"
  ;; When text objects are pre-selected the command line prompt is:
  ;; "Enter to Accept pre-selection or Options? [Accept/Options] <A>:"

  ;; Note, when objects are pre-selected and the current selection option is
  ;; selection order, the selection option is changed to top down because
  ;; pre-selection doesn't make sense with the selection order option.

  ;; The number of converted text objects is reported at the command line when
  ;; the routine ends.

  ;; The shortcut is TTM.

  ;; An associated DCL file is not needed for the options dialog. The DCL file
  ;; is created on-the-fly and deleted when the routine ends.

  ;; Thanks to Steve Doman for his help with the routine.

;; Operation:

  ;; Command: ttm
  ;; Current options:
  ;; Selection: Top Down, Linefeeds: None, Width: Fit, Formatting: Yes, Separate
  ;; objects: No
  ;; The current option settings are displayed at the command line.

  ;; Select objects or Options? [Select/Options] <S>:
  ;; Enter to select objects if the current options apply, or "o" to display
  ;; the options dialog.

  ;; Text objects may be pre-selected before running the routine.

  ;; The last option settings are recalled each time the routine is run.

;; Options dialog:

  ;; Definition of the term "anchor" object. Given the top down selection
  ;; option, the anchor object is the top object in WCS coordinates.
  ;; Given the Selection set order option, the anchor object is the first
  ;; object picked.

  ;; The properties of the anchor text object determine the properties of the
  ;; resulting mtext object. For example, if the text style name of the anchor
  ;; object is "MyStyle", the mtext text style is the same.

  ;; Similarly, the anchor object determines the top left insertion point
  ;; of the mtext object. Justication is always set to top left.

  ;; Selection is a radio button toggle option. Given the top down option,
  ;; the order of the objects is determined by their Y coordinate relative to
  ;; the anchor object. The Selection set order option prompts the user to pick
  ;; each text object, which determines the order of text in the mtext object.

  ;; Linefeeds is a radio button toggle option. Linefeeds are added at the end
  ;; of each each selected text object when the Add linefeeds option is selected.
  ;; Otherwise, linefeeds are not added to the resulting mtext object.

  ;; Width is a radio button toggle option. When Zero width is selected, the
  ;; resulting mtext object has zero defined width. Otherwise, the width is
  ;; determined by the width of the longest line in the text selection set.

  ;; Transfer fomatting is a checkbox option. When checked, all possible
  ;; text formatting is applied to the resulting mtext object using embedded
  ;; mtext formatting codes. For example, if a text object has a color
  ;; assigned other than bylayer, the appropriate formatting codes are added.
  ;; The routine includes support for underline, overline, oblique and width
  ;; formatting, which the ExpressTools routine does not. All text formatting
  ;; is ignored/removed when the option is not checked.

  ;; Note, ACAD versions prior to 2006 do not support embedded overline, width
  ;; and oblique formatting within the mtext editor. The routine will not
  ;; transfer those formatting codes when the version in use is 2005 or earlier.

  ;; Separate objects is a checkbox option. When checked, the selected text
  ;; objects are converted to separate mtext objects, rather than combined
  ;; into one.

;; Version history:

  ;; First release version: TextToMtext v1.lsp posted at theswamp.org 11/25/2011.

  ;; TextToMtext v1a.lsp posted at theswamp.org 12/15/2011.
	;; Added support for conversion of annotative text objects to annotative mtext.
	;; Note, the new mtext object assumes the current annotative scale. No attempt
	;; is made to transfer existing scale(s) to the new mtext object. IMO, this
	;; ensures a consistent and easy to understand interface from the user's
	;; perspective. It's the same as what happens when the chprop command is used
	;; to change a non-annotative text or mtext object to annotative.

	;; Also note, when multiple text objects are combined to one mtext object,
	;; if at least one of the source text objects is annotative, the resulting
	;; mtext object will be annotative.

	;; Thanks to everyone who contributed to this change.

(vl-load-com)

;; -----------------------------------
;; Regular Expression code.
;; Access the RegExp object from the blackboard.
(or
	(vl-bb-ref '*REX*)
	(vl-bb-set '*REX* (vlax-create-object "VBScript.RegExp"))
)

(defun RE:Replace (newstr pat string)
	(vlax-put (vl-bb-ref '*REX*) 'Pattern pat)
	(vlax-put (vl-bb-ref '*REX*) 'Global actrue)
	(vlax-put (vl-bb-ref '*REX*) 'IgnoreCase acfalse)
	(vlax-invoke (vl-bb-ref '*REX*) 'Replace string newstr)
) ;end

(defun RE:Execute (pat string / result match idx lst)
	(vlax-put (vl-bb-ref '*REX*) 'Pattern pat)
	(vlax-put (vl-bb-ref '*REX*) 'Global actrue)
	(vlax-put (vl-bb-ref '*REX*) 'IgnoreCase acfalse)
	(setq result (vlax-invoke (vl-bb-ref '*REX*) 'Execute string))
	(vlax-for x result
		(setq
			match (vlax-get x 'Value)
			idx   (vlax-get x 'FirstIndex)
			;; position within string - zero based - first position is zero
			lst (cons (list match idx) lst)
		)
	)
	lst
) ;end
;; -----------------------------------

(defun c:sl_TextToMtext ( / old_cmd doc layers blocks textstyles mtxtwdth
							sortlst ss press topobj topstr str inspt lay align
							angstr strlst lastfnt lastht lastclr lastwdth lastobl
							basefnt baseht baseobl baseclr basewdth oblang
							filename ans txtsty highltlst version
							precnt postcnt sepobjcnt obj annoflag
							TM:StripFormat TM:RunDCL TM:MakeMText
							TM:TxtBoxWidth TM:MaxWidth
							TM:SortYPos
							TM:InsertionPoint
							TM:FormatFont TM:FormatHeight TM:FormatColor
							TM:FormatWidth TM:FormatUnderline TM:FormatOverline
							TM:GetBlock TM:SeparateObjects TM:SelectionOrder
							TM:GetCurrentOptions TM:FilterLocked
							TM:IsAnnotativeObject
						)

	;; Blackboard variables:
	;; #topdown# = "Yes" or "No"
	;; #hardwrap# = "Yes" or "No"
	;; #fitwidth# = "Yes" or "No"
	;; #formatting# = "Yes" or "No"
	;; #sepobjects# = "Yes" or "No"

(defun TM:RunDCL ( / tmp )
	(setq
		tmp (mai_dcl_model1
				(list (list -15))
				0
				"【多个单行文字实体转多行文字】"
				(list 1 1 30 0.01 -15 nil nil)
				(list
					"参数"
					(list "文字顺序:" (list "RADIO" "由上至下" "按选择先后") (if (eq "Yes" (vl-bb-ref '#topdown#)) "由上至下" "按选择先后"))
					(list "分行处理:" (list "RADIO" "增加分行符" "不加分行符") (if (eq "Yes" (vl-bb-ref '#hardwrap#)) "增加分行符" "不加分行符"))
					(list "文本字宽:" (list "RADIO" "按最长字宽" "不设置宽度") (if (eq "Yes" (vl-bb-ref '#fitwidth#)) "按最长字宽" "不设置宽度"))
					(list "保留原文本格式" "toggle" (if (eq "Yes" (vl-bb-ref '#formatting#)) "1" "0"))
					(list "每个文字独立为一个多重文字" "toggle" (if (eq "Yes" (vl-bb-ref '#sepobjects#)) "1" "0"))
				)
				nil
				nil
			)
	)
	(if tmp
		(progn
			(setq tmp (cadr tmp))
			(vl-bb-set '#topdown# (if (eq "由上至下" (car tmp)) "Yes" "No"))
			(vl-bb-set '#hardwrap# (if (eq "增加分行符" (cadr tmp)) "Yes" "No"))
			(vl-bb-set '#fitwidth# (if (eq "按最长字宽" (caddr tmp)) "Yes" "No"))
			(vl-bb-set '#formatting# (if (eq "0" (cadddr tmp)) "No" "Yes"))
			(vl-bb-set '#sepobjects# (if (eq "0" (nth 4 tmp)) "No" "Yes"))
		)
	)
	(princ)
)




;; StripFormat version 1.0a for AutoCAD 2000 and above.
;; This is a standalone version of the StripFormat function included
;; in StripMtext v5.

;; Copyright Joe Burke 2010

;; The author grants permission to use, copy, and modify this routine
;; for personal use only and for the use of other AutoCAD users within
;; your organization. Selling, modifying, or exchanging this software
;; for a fee, or incorporation within a commercial software product, is
;; expressly prohibited. All other rights are reserved by the author.

;; Please send comments, wish lists, or bug reports to me at
;; lowercase@hawaii.rr.com

;; Version history:

;; Version 1.0 released at theswamp 1/9/2010 with StripMtext v5.
;; Version 1.0a revised the Stacking sub-function to be the same as
;; StripMtext v5.0b.

;; Arguments:
;; str - an mtext string.
;; formats - a list of format code strings or a string.
;; Format code arguments are not case sensitive.
;; Returns a string with selected formatting removed.

;; Examples:
;; Remove Font, Overline and Underline formatting.
;; (StripFormat <mtext string> (list "f" "O" "U"))
;; Or a quoted list:
;; (StripFormat <mtext string> '("f" "O" "U"))
;; Or a string:
;; (StripFormat <mtext string> "fOU")

;; Remove all formatting except Overline and Underline.
;; (StripFormat <mtext string> (list "*" "^O" "^U"))
;; Or a quoted list:
;; (StripFormat <mtext string> '("*" "^O" "^U"))
;; Or a string:
;; (StripFormat <mtext string> "*^O^U")

;; Available codes:
;; A (^A) - Alignment
;; B (^B) - taBs
;; C (^C) - Color
;; F (^F) - Font
;; H (^H) - Height
;; L (^L) - Linefeed (newline, line break, carriage return)
;; O (^O) - Overline
;; Q (^Q) - obliQuing
;; P (^P) - Paragraph (embedded justification, line spacing and indents)
;; S (^S) - Stacking
;; T (^T) - Tracking
;; U (^U) - Underline
;; W (^W) - Width
;; ~ (^~) - non-breaking space
;; * - all formats

(defun TM:StripFormat (str formats / text slashflag lbrace rbrace
									Alignment Tab Color Font Height Linefeed Overline
									Paragraph Oblique Stacking Tracking Underline Width
									Braces HardSpace FormatsToList)

	;; Basic RegEx functions, RE:Replace and RE:Execute, defined above.

	;; Argument: either a list of strings or a string.
	;; Given a list, ensure formats are uppercase.
	;; Given a formats string, convert it to a list of uppercase strings.
	;; Examples: (FormatsToList "fOU") > ("F" "O" "U")
	;;           (FormatsToList "f^OU") > ("F" "^O" "U")
	(defun FormatsToList (arg / lst)
		(cond
			(	(= (type arg) 'LIST) (mapcar 'strcase arg))
			(	(= (type arg) 'STR)
				(while (not (eq "" (substr arg 1)))
					(if (eq "^" (substr arg 1 1))
						(setq
							lst (cons (strcat "^" (substr arg 2 1)) lst)
							arg (substr arg 3)
						)
						(setq
							lst (cons (substr arg 1 1) lst)
							arg (substr arg 2)
						)
					)
				)
				(mapcar 'strcase (reverse lst))
			)
		)
	) ; end FormatsToList

	(setq formats (FormatsToList formats))

	;; Replace linefeeds using this format "\n" with the AutoCAD
	;; standard format "\P". The "\n" format occurs when text is
	;; copied to ACAD from some other application.
	(setq str (RE:Replace "\\P" "\\n" str))

	;;;;; Start remove formatting sub-functions ;;;;;
	;; A format
	(defun Alignment (str) (RE:Replace "" "\\\\A[012];" str))
	;; B format (tabs)
	(defun Tab (str / lst origstr tempstr)
		(setq lst (RE:Execute "\\\\P\\t|[0-9]+;\\t" str))
		(foreach x lst
			(setq
				origstr (car x)
				tempstr (RE:Replace "" "\\t" origstr)
				str     (vl-string-subst tempstr origstr str)
			)
		)
		(RE:Replace " " "\\t" str)
	)
	;; C format
	(defun Color (str)
		;; True color and color book integers are preceded
		;; by a lower case "c". Standard colors use upper case "C".
		(RE:Replace "" "\\\\[Cc][0-9]?[.]?[0-9]+;" str)
	)
	;; F format
	(defun Font (str) (RE:Replace "" "\\\\[Ff].*?;" str))
	;; H format
	(defun Height (str)
		(RE:Replace "" "\\\\H[0-9]?[.]?[0-9]+x;" str)
	)
	;; L format
	;; Leading linefeeds are not converted to spaces.
	(defun Linefeed (str / teststr)
		;; Remove formatting from test string other than linefeeds.
		;; Seems there's no need to check for stacking
		;; because a linefeed will always come before stack formatting.
		(setq
			teststr (Alignment str)
			teststr (Color teststr)
			teststr (Font teststr)
			teststr (Height teststr)
			teststr (Overline teststr)
			teststr (Paragraph teststr)
			teststr (Oblique teststr)
			teststr (Tracking teststr)
			teststr (Underline teststr)
			teststr (Width teststr)
			teststr (Braces teststr)
		)
		;; Remove leading linefeeds.
		(while (eq "\\P" (substr teststr 1 2))
			(setq
				teststr (substr teststr 3)
				str (vl-string-subst "" "\\P" str)
			)
		)
		(RE:Replace " " " \\\\P|\\\\P |\\\\P" str)
	)
	;; O format
	(defun Overline (str) (RE:Replace "" "\\\\[Oo]" str))
	;; The following option is effectively the same as the Remove Formatting >
	;; Remove Paragraph Formatting option avaiable in the 2008 Mtext editor.
	(defun Paragraph (str) (RE:Replace "" "\\\\p.*?;" str))
	;; Q format - numeric value may be negative.
	(defun Oblique (str)
		;; Any real number including negative values.
		(RE:Replace "" "\\\\Q[-]?[0-9]*?[.]?[0-9]+;" str)
	)
	;; S format
	(defun Stacking (str / lst tempstr pos origstr teststr testpos numcheck)
		(setq lst (RE:Execute "\\\\S(.*?)(\\;)" str))
		(foreach x lst
			(setq
				tempstr (car x)
				pos     (cadr x)
				origstr tempstr
				;; Remove formatting from test string other than stacking.
				teststr (Alignment str)
				teststr (Color teststr)
				teststr (Font teststr)
				teststr (Height teststr)
				teststr (Linefeed teststr)
				teststr (Overline teststr)
				teststr (Paragraph teststr)
				teststr (Oblique teststr)
				teststr (Tracking teststr)
				teststr (Underline teststr)
				teststr (Width teststr)
				teststr (Braces teststr)
				;; Remove all "{" characters if present.
				eststr (RE:Replace "" "[{]" teststr)
				;; Get the stacked position within test string.
				testpos (cadar (RE:Execute "\\\\S(.*?)(\\;)" teststr))
			)
			;; Avoid an error with substr if testpos is zero.
			;; A space should not be added given a stacked
			;; fraction string which is simply like this 1/2" anyway.
			(or (= 0 testpos)
				(setq numcheck (substr teststr testpos 1))
			)
			;; Check whether the character before a stacked string/fraction
			;; is a number. Add a space if it is.
			(setq
				x (if (and numcheck (<= 48 (ascii numcheck) 57)) " " "")
				tempstr (RE:Replace x "\\\\S" tempstr)
				tempstr (RE:Replace "/" "[#]" tempstr)
				tempstr (RE:Replace "" "[;]" tempstr)
				tempstr (RE:Replace "" "\\\\A(.*?)[;]" tempstr)
				tempstr (RE:Replace "" "\\^" tempstr)
				str     (vl-string-subst tempstr origstr str pos)
			)
		)
		str
	)
	;; T format
	(defun Tracking (str) (RE:Replace "" "\\\\T[0-9]?[.]?[0-9]+;" str))
	;; U format
	(defun Underline (str) (RE:Replace "" "\\\\[Ll]" str))
	;; W format
	(defun Width (str) (RE:Replace "" "\\\\W[0-9]?[.]?[0-9]+;" str))
	;; ~ format
	;; In 2008 a hard space includes font formatting.
	;; In 2004 it does not, simply this \\~.
	(defun HardSpace (str) (RE:Replace " " "{\\\\[Ff](.*?)\\\\~}|\\\\~" str))
	;; Remove curly braces. Called after other formatting is removed.
	(defun Braces (str / lst origstr tempstr len teststr)
		(setq lst (RE:Execute "{[^\\\\]+}" str))
		(foreach x lst
			(setq
				origstr (car x)
				tempstr (RE:Replace "" "[{}]" origstr)
				str     (vl-string-subst tempstr origstr str)
			)
		)
		;; Last ditch attempt at remove braces from start and end of string.
		(setq len (strlen str))
		(and
			(= 123 (ascii (substr str 1 1)))
			(= 125 (ascii (substr str len 1)))
			(setq teststr (substr str 2))
			(setq teststr (substr teststr 1 (1- (strlen teststr))))
			(not (vl-string-search "{" teststr))
			(not (vl-string-search "}" teststr))
			(setq str teststr)
		)
		str
	)

	;;;;; End remove formatting sub-functions ;;;;;
	;;;;; Start primary function ;;;;;
	;; Temporarily replace literal backslashes with a unique string.
	;; Literal backslashes are restored at end of function. By Steve Doman.
	(setq
		slashflag (strcat "<" (substr (rtos (getvar "CDATE") 2 8) 14) ">")
		text (RE:Replace slashflag "\\\\\\\\" str)
		;; Temporarily replace literal left curly brace.
		lbrace (strcat "<L" (substr (rtos (getvar "CDATE") 2 8) 14) ">")
		text (RE:Replace lbrace "\\\\{" text)
		;; Temporarily replace literal right curly brace.
		rbrace (strcat "<" (substr (rtos (getvar "CDATE") 2 8) 14) "R>")
		text (RE:Replace rbrace "\\\\}" text)
	)

	(if (or (vl-position "A" formats)
			(and (vl-position "*" formats) (not (vl-position "^A" formats)))
		)
		(setq text (Alignment text))
	)
	(if (or (vl-position "B" formats)
			(and (vl-position "*" formats) (not (vl-position "^B" formats)))
		)
		(setq text (Tab text))
	)
	(if (or (vl-position "C" formats)
			(and (vl-position "*" formats) (not (vl-position "^C" formats)))
		)
		(setq text (Color text))
	)
	(if (or (vl-position "F" formats)
			(and (vl-position "*" formats) (not (vl-position "^F" formats)))
		)
		(setq text (Font text))
	)
	(if (or (vl-position "H" formats)
			(and (vl-position "*" formats) (not (vl-position "^H" formats)))
		)
		(setq text (Height text))
	)
	(if (or (vl-position "L" formats)
			(and (vl-position "*" formats) (not (vl-position "^L" formats)))
		)
		(setq text (Linefeed text))
	)
	(if (or (vl-position "O" formats)
			(and (vl-position "*" formats) (not (vl-position "^O" formats)))
		)
		(setq text (Overline text))
	)
	(if (or (vl-position "P" formats)
			(and (vl-position "*" formats) (not (vl-position "^P" formats)))
		)
		(setq text (Paragraph text))
	)
	(if (or (vl-position "Q" formats)
			(and (vl-position "*" formats) (not (vl-position "^Q" formats)))
		)
		(setq text (Oblique text))
	)
	(if (or (vl-position "S" formats)
			(and (vl-position "*" formats) (not (vl-position "^S" formats)))
		)
		(setq text (Stacking text))
	)
	(if (or (vl-position "T" formats)
			(and (vl-position "*" formats) (not (vl-position "^T" formats)))
		)
		(setq text (Tracking text))
	)
	(if (or (vl-position "U" formats)
			(and (vl-position "*" formats) (not (vl-position "^U" formats)))
		)
		(setq text (Underline text))
	)
	(if (or (vl-position "W" formats)
			(and (vl-position "*" formats) (not (vl-position "^W" formats)))
		)
		(setq text (Width text))
	)
	(if (or (vl-position "~" formats)
			(and (vl-position "*" formats) (not (vl-position "^~" formats)))
		)
		(setq text (HardSpace text))
	)
	(setq
		text (Braces (RE:Replace "\\\\" slashflag text))
		text (RE:Replace "\\{" lbrace text)
		text (RE:Replace "\\}" rbrace text)
	)
	text
) ; end TM:StripFormat

;; Argument: text vla-object.
;; Returns: If the active version is 2005 or later, the field code string.
;; Otherwise the TextString property of the text object.
;; Fields were added in ACAD version 2005.

;; Looks right, regardless of the Alignment property of the text object.
;; Argument: the top text vla-object.
(defun TM:InsertionPoint (obj / elst tbox ip ll ur ul RotatePt ent)
	;; pt - point to rotate
	;; bp - rotation base point
	;; ang - rotation angle in radians
	(defun RotatePt (pt bp ang)
		(polar bp (+ (angle bp pt) ang) (distance bp pt))
	)
	(if (= 'ename (type obj))
		(setq ent obj obj (vlax-ename->vla-object obj))
		(setq ent (vlax-vla-object->ename obj))
	)
	(setq
		elst (entget ent)
		tbox (textbox elst)
		ll (car tbox)
		ur (cadr tbox)
		ip (vlax-get obj 'InsertionPoint)
		ul (list (car ll) (cadr ur) 0.0)
		ul (mapcar '+ ip ul)
	)
	(RotatePt ul (mapcar '+ ip ll) (vlax-get obj 'Rotation))
) ;end TM:InsertionPoint







  ;; Argument: a list of vla-objects.
  ;; Returns a list of vla objects sorted on Y postion top to bottom.
  ;; Works in a rotated UCS,
(defun TM:SortYPos ( lst )
	(setq
		lst (mapcar '(lambda (x) (cons (vlax-get x 'InsertionPoint) x)) lst)
		lst (vl-sort
				lst
				'(lambda (x y)
					(if (mai_equal (cadar x) (cadar y))
						(< (caar x) (caar y))
						(> (cadar x) (cadar y))
					)
				)
			)
	)
	(mapcar 'cdr lst)
) ; end TM:SortYPos

;; Revised 10/13/2011.
;; When formating is removed, the width of the resulting mtext object
;; is adjusted accordingly. This applies when the text source object(s)
;; have a width property which differs from the the width defined by the
;; text style definition.
(defun TM:TxtBoxWidth (obj / elst tbox ll ur lr dis factor txtsty basewdth)
	(setq
		elst (entget (vlax-vla-object->ename obj))
		tbox (textbox elst)
		ll (car tbox)
		ur (cadr tbox)
		lr (list (car ur) (cadr ll))
		dis (distance ll lr)
	)
	(if (eq "Yes" (vl-bb-ref '#formatting#))
		dis
		; else fomatting is removed
		(progn
			(setq
				txtsty (vlax-get obj 'StyleName)
				basewdth (vlax-get (vla-item textstyles txtsty) 'Width)
				factor (/ basewdth (vlax-get obj 'ScaleFactor))
			)
			(* dis factor)
		)
	)
) ; end TM:TxtBoxWidth

(defun TM:MaxWidth ( lst / wlst)
	(foreach x lst (setq wlst (cons (TM:TxtBoxWidth x) wlst)))
	(apply 'max wlst)
) ; end TM:MaxWidth


;; Returns an mtext vla-object if successful.
(defun TM:MakeMText (string pt lay size ang width align styl clr / obj)
	(if (> version 16.2)
		(setq string (TM:StripFormat string "OQW"))
	)
	(if (entmake
			(list
				'(0 . "MTEXT")
				'(100 . "AcDbEntity")
				'(100 . "AcDbMText")
				(cons 1 string)
				(cons 10 pt)
				(cons 40 size)
				(cons 41 width)
				(cons 7 styl)
				(cons 50 ang)
				(cons 8 lay)
				(cons 71 align)
				(cons 62 clr)
			)
		)
		(setq obj (vlax-ename->vla-object (entlast)))
	)
	;; This is needed for fields to work.
	(if obj (vlax-put obj 'TextString string)) ;; feels a bit funky here
	obj
) ; end TM:MakeMText

;; Revised 9/14/2011 - use the FontFile property of the text style
;; defintiton rather than the stylename of the object.
;; basefnt is something like "Arial.TTF"
(defun TM:FormatFont (basefnt obj str / objfnt)
	(setq
		objfnt (vlax-get obj 'StyleName)
		objfnt (vlax-get (vla-item textstyles objfnt) 'FontFile)
	)
	(or lastfnt (setq lastfnt basefnt))
	(cond
		;; This is needed
		(	(not (eq objfnt lastfnt))
			(setq str (strcat "\\F" objfnt ";" str))
		)
		; (	(and (/= objfnt basefnt) (not (eq objfnt lastfnt)))
			; (setq str (strcat "\\F" objfnt ";" str))
		; )
	)
	(setq lastfnt objfnt)
	str
) ; end TM:FormatFont

(defun TM:FormatHeight (ht obj str / objht newht)
	(setq objht (vlax-get obj 'Height))
	(or lastht (setq lastht ht))
	(or (and (mai_equal ht objht) (mai_equal objht lastht))
		(setq newht (/ objht lastht) str (strcat "\\H" (rtos newht 2 5) "x;" str))
	)
	(setq lastht objht)
	str
) ; end TM:FormatHeight

(defun TM:FormatColor (clr obj str / objclr)
	(setq objclr (vlax-get obj 'Color))
	(or lastclr (setq lastclr clr))
	(cond
		; (	(not (eq objclr lastclr))
			; (setq str (strcat "\\C" (itoa objclr) ";" str))
		; )
		(	(and (/= objclr 256) (not (eq objclr lastclr)))
			(setq str (strcat "\\C" (itoa objclr) ";" str))
		)
	)
	(setq lastclr objclr)
	str
) ; end TM;FormatColor

(defun TM:FormatWidth (wdth obj str / objwdth)
	(setq objwdth (vlax-get obj 'ScaleFactor))
	(or lastwdth (setq lastwdth wdth))
	(cond
		; (	(not (mai_equal objwdth lastwdth))
			; (setq str (strcat "\\W" (rtos objwdth 2 6) ";" str))
		; )
		(	(not (or (mai_equal objwdth wdth) (mai_equal objwdth lastwdth)))
			(setq str (strcat "\\W" (rtos objwdth 2 6) ";" str))
		)
	)
	(setq lastwdth objwdth)
	str
) ; end TM:FormatWidth

(defun TM:FormatOblique (obl obj str / ang )
	(setq ang (vlax-get obj 'ObliqueAngle))
	(or lastobl (setq lastobl obl))
	(cond
		(	(not (eq ang lastobl))
			(setq str (strcat "\\Q" (rtos (/ (* ang 180.0) pi) 2 2) ";" str))
		)
		; (	(and (/= ang 0.0) (not (eq ang lastobl)))
			; (setq str (strcat "\\Q" (rtos (/ (* ang 180.0) pi) 2 2) ";" str))
		; )
	)
	(setq lastobl ang)
	str
) ; end FormatOblique

;; The doc var is defined in the main routine.
(defun TM:GetBlock ( )
	(vlax-get (vla-get-ActiveLayout doc) 'Block)
) ;end TM:GetBlock



;; The doc and block vars are defined in the main routine.
(defun TM:FormatUnderline (srcstr / actlay lockflag lst
									  dim blkname blk str)
	;; Check for active layer locked.
	(setq actlay (vlax-get doc 'ActiveLayer))
	(if (= -1 (vlax-get actlay 'Lock))
		(progn
			(vlax-put actlay 'Lock 0)
			(setq lockflag T)
		)
	)
	(setq
		lst (RE:Execute "%%U|%%u" srcstr)
		dim (vlax-invoke (TM:GetBlock) 'AddDimRotated '(0.0 0.0 0.0) '(0.0 0.0 0.0) '(0.0 0.0 0.0) 0.0 )
	)
	(vlax-put dim 'TextOverride srcstr)
	;; Get the mtext string from the dimension block.
	(setq
		blkname (mai_dxf 2 (vlax-vla-object->ename dim))
		blk (vla-item blocks blkname)
	)
	(vlax-for x blk
		(if (eq "AcDbMText" (vlax-get x 'ObjectName))
			(setq str (mai_get_textstring x))
		)
	)
	;; Remove alignment "\\A1;...
	;; Remove width "\\W;...
	(setq str (RE:Replace "" "\\\\W[0-9]?[.]?[0-9]+;" (RE:Replace "" "\\\\A[012];" str)))
	(vla-delete dim)
	;; Delete dim block.
	(vla-delete blk)
	(if lockflag (vlax-put actlay 'Lock -1))
	(or (= 0 (rem (length lst) 2))
		(setq str (strcat str "\\l"))
	)
	str
) ;end TM:FormatUnderline

(defun TM:FormatOverline (srcstr / lst)
	(setq lst (RE:Execute "\\\\[Oo]" srcstr))
	(if (= 0 (rem (length lst) 2))
		srcstr
		(strcat srcstr "\\o")
	)
) ;end TM:FormatOverline

;; Used when the Separate objects option is chosen.
;; New version 10/26/2011 - takes a vla-object list argument
(defun TM:SeparateObjects (lst / str inspt lay clr ang align sty basewdth
								   wdth oblang angstr annoflag obj)

	;; Added 12/4/2011 - this seems to fix the problem with pre-selection.
	(sssetfirst)
	(setq sepobjcnt (length lst))
	(foreach x lst
		(setq
			annoflag (TM:IsAnnotativeObject x)
			str (mai_get_textstring x)
		;; Added 10/02/2011. Replace "%%%" with "%".
			str (RE:Replace "%" "%%%" str)
		)
		(if (RE:Execute "%%U|%%u|%%O|%%o" str)
			(setq str (TM:FormatUnderline str))
		)
		(setq
			inspt (TM:InsertionPoint x)
			lay (vlax-get x 'Layer)
			clr (vlax-get x 'Color)
			ht (vlax-get x 'Height)
			ang (mai_trans_ang (vlax-get x 'Rotation) 0 1)
			align 1
			sty (vlax-get x 'StyleName)
			basewdth (vlax-get (vla-item textstyles sty) 'Width)
			wdth (if (eq "Yes" (vl-bb-ref '#fitwidth#)) (* 1.03 (TM:TxtBoxWidth x)) 0.0)
		)
		(or (mai_equal basewdth (vlax-get x 'ScaleFactor))
			(setq str (strcat "\\W" (rtos (vlax-get x 'ScaleFactor) 2 6) ";" str))
		)
		(or (mai_equal_angle 0.0 (vlax-get x 'ObliqueAngle))
			(setq
				oblang (vlax-get x 'ObliqueAngle)
				angstr (rtos (/ (* oblang 180.0) pi) 2 2)
				str (strcat "\\Q" angstr ";" str)
			)
		)
		(if (eq "No" (vl-bb-ref '#formatting#))
			(setq str (TM:StripFormat str "OUCHQWF"))
		)
		(setq obj (TM:MakeMText str inspt lay ht ang wdth align sty clr))
		(if annoflag
			(command "._chprop" (vlax-vla-object->ename obj) "" "_Annotative" "_Yes" "")
		)
	) ; foreach
	(foreach x lst
		(or (vlax-erased-p x) (vla-delete x))
	)
) ; end TM:SeparateObjects

;; Returns a list of vla-objects in the order they were selected.
;; Objects on locked layers are not included.
;; Revised 11/4/2011 to remove object on locked layer checking.
;; Allow the TM:FilterLocked function to remove objects from
;; the list. Operation is more consistent this way in the sense
;; selected objects on locked layers are highlighted as they
;; are with a selection set.
(defun TM:SelectionOrder ( / lst e typ obj temp)
	(sssetfirst)
	; (princ "\nFirst object selected sets the insertion point. ")
	(princ "\n以第一个文选择的文字确定多重文字插入点 .")
	(setvar "errno" 0)
	;while user doesn't hit Enter
	(while (/= 52 (getvar "errno"))
		; (if (setq e (car (entsel "\nSelect text object, or Enter to end selection: ")))
		(if (setq e (car (entsel "\n多选单行文字, 或回车获得上一次选择 :")))
			(progn
				(setq
					obj (vlax-ename->vla-object e)
					typ (mai_dxf 0 e)
				)
				(if (and
						(eq "TEXT" typ)
						;; Don't add duplicate selected objects to the list.
						(not (vl-position obj lst))
					)
					(progn
						;; Added 9/20/2011. highltlst is called in the error handler to
						;; unhighlight objects in case the user cancels while picking objects.
						(vlax-invoke obj 'Highlight actrue)
						(setq
							lst (cons obj lst)
							highltlst (cons obj highltlst)
						)
					)
					;; else
					(or (eq "TEXT" typ)
						(progn
							; (princ (strcat "\nIncorrect object type: " typ))
							(princ (strcat "\n实体类型不符合 :" typ))
							(setq temp (cons typ temp))
						)
					)
				)
			)
		)
	) ; while not Enter
	;; Exit if all selected objects are not text.
	(and temp
		(not lst)
		(progn
			; (princ "\nNo text objects selected. ")
			(princ "\n没有选择到单行文字实体 .")
			(exit)
		)
	)
	(if lst (TM:FilterLocked (reverse lst)))
) ; end TM:SelectionOrder

;; Print the current options at the command line.
;; Revised 10/10/2011.
(defun TM:GetCurrentOptions ( / strlst resstr)

	(setq
		strlst (cons (if (eq "Yes" (vl-bb-ref '#topdown#)) "选择集 : 自上而下 , " "选择集 : 选择顺序 , ") strlst)
		strlst (cons (if (eq "Yes" (vl-bb-ref '#hardwrap#)) "换行符 : 增加 , " "换行符 : 不加 , ") strlst)
		strlst (cons (if (eq "Yes" (vl-bb-ref '#fixwidth#)) "宽度: 自适应 ," "宽度: 零 ,") strlst)
		strlst (cons (if (eq "Yes" (vl-bb-ref '#formatting#)) "保留文字格式: 是 ," "保留文字格式: 否 ,") strlst)
		strlst (cons (if (eq "Yes" (vl-bb-ref '#sepobjects#)) "独立实体: 是 " "独立实体: 否 ") strlst)
		resstr (apply 'strcat (cons "\n当前选项 : \n" (reverse strlst)))
	)
	(princ resstr)
) ; end TM:GetCurrentOptions


;; Argument: either a selection set or a list of vla-objects.
;; Returns: a list of vla-objects in the same order as passed
;; with objects on locked layer filtered out. The routine ends
;; if all objects are on locked layers.
(defun TM:FilterLocked ( lst / lays)
	(setq
		lst (mai_ssget_2_list lst)
		lays (vl-remove-if-not 'mai_get_layer_locked (mai_tblsearch "layer"))
		lst (vl-remove-if '(lambda(x)(member (strcase (mai_dxf 8 x)) lays)) lst)
	)
	(or lst
		(progn
			; (princ "\nAll objects are on locked layers or incorrect object types. ")
			(princ "\n所有的实体在被锁定的图层或实体类型不正确 .")
			;(princ "\nAll selected objects are on locked layers. ")
			(exit)
		)
	)
	(mapcar 'vlax-ename->vla-object lst)
)

;; The issue here is, as Lee Mac pointed out, when an object is converted
;; from annotative to non-annotative, the DXF data related to annotative
;; remains. What changes is the value associated with DXF code 1070.
;; If the value is 1, the object is annotative.
;; If the value is 0, the object is not annotative.
;; Based on code by Lee Mac at theswamp.org.
;; Returns T if the object passed is annotative, otherwise nil.
;; Note, the former IsAnnotative function by Ian Bryant works equally as well.
;; I'm replacing that function with this because the intent of this code
;; is more obvious. I suspect it may also be faster... not tested.
(defun TM:IsAnnotativeObject (e / anno)
	(if (= (type e) 'VLA-OBJECT)
		(setq e (vlax-vla-object->ename e))
	)
	(and
		(setq anno (cadr (assoc -3 (entget e '("AcadAnnotative")))))
		(= 1 (mai_dxf 1070 (reverse anno)))
	)
) ; end TM:IsAnnotativeObject

;; Argument may be a selection set or list of vla-objects.
;; Returns T if some or all of the objects passed are annotative.
(defun TM:AnnotativeList ( ss )
	(vl-some 'TM:IsAnnotativeObject (mai_ssget_2_objs ss))
) ; end TM:AnnotativeList

	;;; END SUB-FUNCTIONS ;;;

	;;; START MAIN FUNCTION ;;;
	(mini_start nil)
	(mai_last_com "SL_TextToMtext")
	(setq
		doc (vla-get-ActiveDocument (vlax-get-acad-object))
		layers (vla-get-layers doc)
		blocks (vla-get-Blocks doc)
		textstyles (vla-get-TextStyles doc)
		precnt (vlax-get (TM:GetBlock) 'Count)
		;; Determine vesion in use.
		version (atof (getvar "acadver"))
	)
	;; Set default options.
	(or (vl-bb-ref '#topdown#) ;; but1
		(vl-bb-ref '#hardwrap#) ;; but4
		(vl-bb-ref '#fitwidth#) ;; but5
		(vl-bb-ref '#formatting#) ;; but7
		(vl-bb-ref '#sepobjects#) ;; but8
		(progn
			(vl-bb-set '#topdown# "Yes")
			(vl-bb-set '#hardwrap# "Yes")
			(vl-bb-set '#fitwidth# "Yes")
			(vl-bb-set '#formatting# "Yes")
			(vl-bb-set '#sepobjects# "No")
		)
	)
	; (or (vl-bb-ref '#lastselopt#)
		; (vl-bb-set '#lastselopt# "but1")
	; )
	; (or (vl-bb-ref '#lastwrap#)
		; (vl-bb-set '#lastwrap# "but3")
	; )

	;; If preselection not allowed, deselect any pre-slected objects.
	; (if (= 0 (getvar "pickfirst"))
		; (sssetfirst)
	; )

	; (setvar "cmdecho" 0)

	;; Revised per Steve's suggestion 11/16/2011.
	;; When there is pre-selection, default to topdown selection because
	;; the selection order option doesn't make sense with pre-selection.
	;; Revised 11/24/2011 to prevent a condition where both top down and seperate
	;; object are checked in the dialog and set to Yes in the blackboard.
	;; This works without consideration of the status of sepearate objects
	;; because selection order will always be No if separate objects is Yes.
	; (if (setq press (ssget "I" '((0 . "TEXT"))))
	(if (setq press (nth 5 old_cmd))
		(vl-bb-set '#topdown# "Yes")
	)

	;; Print the current options to the command line.
	(TM:GetCurrentOptions)

	;;;;;;;;; START NO PRE-SELECTION ;;;;;;;;;

	(cond
		(	(not press)
			; (and
				; (eq "No" (vl-bb-ref '#topdown#))
				; (setq sortlst (TM:SelectionOrder))
				; (setq topobj (car sortlst) inspt (TM:InsertionPoint topobj))
			; )
			(if (eq "Yes" (vl-bb-ref '#topdown#))
				(setq ss (mai_ssget_2_list (mai_select_firsts (list (cons 0 "text")) "选择文字实体：<回车空选设置>" "没有选择文字" nil)))
				(and
					(setq sortlst (TM:SelectionOrder))
					(setq topobj (car sortlst) inspt (TM:InsertionPoint topobj))
				)
			)
			(if (or (and (not sortlst) (eq "No" (vl-bb-ref '#topdown#)))
					(and (not ss) (eq "Yes" (vl-bb-ref '#topdown#)))
				)
				(TM:RunDCL)
			)
			(cond
				(	(or (and (not sortlst) (eq "No" (vl-bb-ref '#topdown#)))
						(and (not ss) (eq "Yes" (vl-bb-ref '#topdown#)))
					)
					(cond
						(	(eq "Yes" (vl-bb-ref '#sepobjects#))
							(if (setq ss (mai_select_firsts (list (cons 0 "text")) "选择文字实体：<退出>" "没有选择文字" nil))
								(TM:SeparateObjects (TM:FilterLocked ss))
							)
						)
						(	(eq "Yes" (vl-bb-ref '#topdown#))
							(if (setq ss (mai_select_firsts (list (cons 0 "text")) "选择文字实体：<退出>" "没有选择文字" nil))
								(setq
									ss (TM:FilterLocked ss)
									sortlst (TM:SortYPos ss)
									topobj (car sortlst)
									inspt (TM:InsertionPoint topobj)
								)
							)
						)
						(	(setq sortlst (TM:SelectionOrder))
							(setq
								topobj (car sortlst)
								inspt (TM:InsertionPoint topobj)
							)
						)
					) ; cond
				) ; cond not ss
				;; cond ss is true
				(	ss
					(cond
						(	(eq "Yes" (vl-bb-ref '#sepobjects#))
							(TM:SeparateObjects (TM:FilterLocked ss))
						)
						(	(eq "Yes" (vl-bb-ref '#topdown#))
							(setq
								ss (TM:FilterLocked ss)
								sortlst (TM:SortYPos ss)
								topobj (car sortlst)
								inspt (TM:InsertionPoint topobj)
							)
						)
						(	(setq sortlst (TM:SelectionOrder))
							(setq
								topobj (car sortlst)
								inspt (TM:InsertionPoint topobj)
							)
						)
					)
				)
			)
		)
	) ; end cond pre-selection No

	;;;;;;;;; END NO PRE-SELECTION ;;;;;;;;;;;;;;;

	;;;;;;;;; START YES PRE-SELECTION ;;;;;;;;;;;;;

	(cond
		(	press
			(initget "Options")
			; (setq ans (getkword "\nEnter to Accept pre-selection or Options? [Accept/Options] :<A>"))
			(setq ans (getkword "\[Options设置] :<回车确认>"))
			(if (eq ans "Options") (TM:RunDCL))
			(cond
				(	(eq "Yes" (vl-bb-ref '#sepobjects#))
					(TM:SeparateObjects (TM:FilterLocked press))
				)
				(	(eq "Yes" (vl-bb-ref '#topdown#))
					(setq
						sortlst (TM:SortYPos (TM:FilterLocked press))
						topobj (car sortlst)
						inspt (TM:InsertionPoint topobj)
					)
					;; keep this
					(sssetfirst)
				)
				(	T
					(setq
						sortlst (TM:SelectionOrder)
						topobj (car sortlst)
						inspt (TM:InsertionPoint topobj)
					)
				)
			)
		)
	) ; end cond pre-selection Yes

	;;;;;;;;; END YES PRE-SELECTION ;;;;;;;;;

	;; This test seems sufficient. The following code does not execute
	;; if the sparate objects option is chosen because sortlst is nil.
	(if sortlst
		(progn
			(if (TM:AnnotativeList sortlst) (setq annoflag T))
			(setq topstr (mai_get_textstring topobj))
			;; Regarding text format codes %%d - degree symbol,
			;; %%c - circle diameter symbol and %%p - plus/minus symbol,
			;; these formatting codes work in mtext strings the same as
			;; in text strings. No coded needed to deal with these.
			;; Added 10/02/2011. Replace "%%%" with "%".
			(setq topstr (RE:Replace "%" "%%%" topstr))
			;; Test the string for underline and overline.
			(if (RE:Execute "%%U|%%u|%%O|%%o" topstr)
				(setq topstr (TM:FormatOverline (TM:FormatUnderline topstr)))
			)
			(setq
				align 1
				topstr (strcat (vl-string-right-trim " " topstr) " ")
				lay (vlax-get topobj 'Layer)
				baseht (vlax-get topobj 'Height)
				baseang (mai_trans_ang (vlax-get topobj 'Rotation) 0 1)
				baseht (vlax-get topobj 'Height)
				txtsty (vlax-get topobj 'StyleName)
				basefnt (vlax-get (vla-item textstyles txtsty) 'FontFile)
				;; revised 9/26/2011 - treat color like layer because it's
				;; a property of the resulting mtext object.
				baseclr (vlax-get topobj 'Color)
				;; Base width and base oblique treated the same.
				;; Base width is a property of the text style definition.
				basewdth (vlax-get (vla-item textstyles txtsty) 'Width)
			)
			(or (mai_equal basewdth (vlax-get topobj 'ScaleFactor))
				(setq
					topstr (strcat "\\W" (rtos (vlax-get topobj 'ScaleFactor) 2 6) ";" topstr)
					lastwdth (vlax-get topobj 'ScaleFactor)
				)
			)
			;; Base oblique is a property of the text style definition.
			(setq baseobl (vlax-get (vla-item textstyles txtsty) 'ObliqueAngle))
			(or (= baseobl (vlax-get topobj 'ObliqueAngle))
				(setq
					oblang (vlax-get topobj 'ObliqueAngle)
					angstr (rtos (/ (* oblang 180.0) pi) 2 2)
					topstr (strcat "\\Q" angstr ";" topstr)
					lastobl oblang
				)
			)
			(if (eq "Yes" (vl-bb-ref '#hardwrap#))
				(setq topstr (strcat topstr "\\P"))
			)
			(if (eq "No" (vl-bb-ref '#formatting#))
				(setq topstr (TM:StripFormat topstr "OUCHQWF"))
			)
			(setq
				strlst (cons topstr strlst)
				mtxtwdth (if (eq "Yes" (vl-bb-ref '#fitwidth#)) (* 1.03 (TM:MaxWidth sortlst)) 0.0)
			)
			(foreach i (cdr sortlst)
				(setq str (RE:Replace "%" "%%%" (mai_get_textstring i)))
				;; Test the string for underline and overline.
				(if (RE:Execute "%%U|%%u|%%O|%%o" str)
					(setq str (TM:FormatOverline (TM:FormatUnderline str)))
				)
				(setq
					str (strcat (vl-string-right-trim " " str) " ")
					str (TM:FormatFont basefnt i str)
					str (TM:FormatHeight baseht i str)
					str (TM:FormatColor baseclr i str)
					str (TM:FormatWidth basewdth i str)
					str (TM:FormatOblique baseobl i str)
				)
				(if (eq "Yes" (vl-bb-ref '#hardwrap#))
					(setq str (strcat str "\\P"))
				)
				(if (eq "No" (vl-bb-ref '#formatting#))
					(setq str (TM:StripFormat str "OUCHQWF"))
				)
				(setq strlst (cons str strlst))
			) ; foreach
			(setq
				strlst (reverse strlst)
				str (apply 'strcat strlst)
				str (vl-string-right-trim " \\P" str)
			)
			(foreach x sortlst (or (vlax-erased-p x) (vla-delete x)))
			(setq obj (TM:MakeMText str inspt lay baseht baseang mtxtwdth align txtsty baseclr))
			(if annoflag
				(command "._chprop" (vlax-vla-object->ename obj) "" "_Annotative" "_Yes" "")
			)
		)
	) ;if sortlst

	;; Report added 11/24/2011.
	(cond
		(	(and
				sepobjcnt
				(eq "Yes" (vl-bb-ref '#sepobjects#))
			)
			(princ (strcat "\n[ " (itoa sepobjcnt) " ]个单行文字实体被转换 :" ))
		)
		(	T
			(setq postcnt (vlax-get (TM:GetBlock) 'Count))
			(princ (strcat "\n[ " (itoa (1+ (- precnt postcnt))) " ]个单行文字实体被转换 :" ))
		)
	)
	(mai_end)
) ; end TextToMtext
