Have you ever wanted to take off the "clothes" of Mtext. Well, here you are. A Mtext unformatter. It is a nice little routine, that I built from a post on the Autodesk forum site. I apologize to the author but I do not have their name. I tweaked it just a little but the main idea is still there.
Public Function MText_Unformat(ByVal sTxt As String) As String
'------------------------------------------------------------------------------
'Remove formatting strings
'
'Value Examples:
' \A Sets the alignment value; valid values: 0, 1, 2 (bottom, center, top)
' \Cvalue; Changes to the specified color
' \Hvalue; Changes to the specified text height
' \Hvaluex; Changes to multiple of mtext object's property
' \L...\l Turns underline on and off
' \O...\o Turns overline on and off
' \P Ends paragraph/Carriage return
' \Qangle; Changes obliquing angle
' \S...^...; Stacks the subsequent text at the \ or ^ symbol
' \Tvalue; Adjusts the space between characters
' \Wvalue; Changes width factor to produce wide text
' \~ Inserts a nonbreaking space
' \\ Inserts a backslash
' \{...\} Inserts an opening and closing brace
' \File name; Changes to the specified font file
'
'------------------------------------------------------------------------------
Dim P1 As Integer
Dim P2 As Integer
Dim P3 As Integer
Dim iStart As Integer
Dim sComp As String
Dim sReplace As String
Dim sLittle As String
'''''''''''''''''''''''''''''''''''''''
Debug.Print sTxt
'------------------------------------------------------------------------------
'Remove alignment codes
'------------------------------------------------------------------------------
Select Case Left(sTxt, 4)
Case "\A0;", "\A1;", "\A2;"
sTxt = Mid(sTxt, P1 + 5)
End Select
iStart = 1
'------------------------------------------------------------------------------
'Replace octal code values with strings
'------------------------------------------------------------------------------
Do
P1 = InStr(sTxt, "%%")
If P1 = 0 Then
Exit Do
Else
Select Case Mid(sTxt, P1 + 2, 1)
Case "P"
sTxt = Replace(sTxt, "%%P", "+or-")
Case "D"
sTxt = Replace(sTxt, "%%D", " deg")
End Select
End If
Loop
Do
P1 = InStr(iStart, sTxt, "\", vbTextCompare)
If P1 = 0 Then Exit Do
sComp = Mid(sTxt, P1, 2)
Select Case sComp
Case "\p"
P2 = InStr(1, sTxt, ";")
sTxt = Mid(sTxt, P2 + 1)
Case "\A", "\C", "\f", "\F", "\H", "\Q", "\T", "\W"
P2 = InStr(P1 + 2, sTxt, ";", vbTextCompare)
P3 = InStr(P1 + 2, sTxt, sComp, vbTextCompare)
If P3 = 0 Then
sTxt = Left(sTxt, P1 - 1) & Mid(sTxt, P2 + 1)
End If
Do While P3 > 0
P2 = InStr(P3, sTxt, ";", vbTextCompare)
sTxt = Left(sTxt, P3 - 1) & Mid(sTxt, P2 + 1)
'Debug.Print sTxt, sComp
P3 = InStr(1, sTxt, sComp, vbTextCompare)
Loop
'sTxt = Left(sTxt, P3 - 1) & mid(sTxt, P3 + 1)
Case "\L", "\O"
sLittle = LCase(sComp)
P2 = InStr(P1 + 2, sTxt, sLittle, vbTextCompare)
If P2 = 0 Then
sTxt = Left(sTxt, P1 - 1) & Mid(sTxt, P1 + 2)
Else
sTxt = Left(sTxt, P1 - 1) & Mid(sTxt, P1 + 2, P2 - (P1 + 2)) & Mid(sTxt, P2 + 2)
End If
Case "\S"
P2 = InStr(P1 + 2, sTxt, ";", vbTextCompare)
P3 = InStr(P1 + 2, sTxt, "/", vbTextCompare)
If P3 = 0 Or P3 > P2 Then
P3 = InStr(P1 + 2, sTxt, "#", vbTextCompare)
End If
If P3 = 0 Or P3 > P2 Then
P3 = InStr(P1 + 2, sTxt, "^", vbTextCompare)
End If
sTxt = Left(sTxt, P1 - 1) & Mid(sTxt, P1 + 2, P3 - (P1 + 2)) _
& "/" & Mid(sTxt, P3 + 1, (P2) - (P3 + 1)) & Mid(sTxt, P2 + 1)
Case "\U" 'Replace symbols with text
sLittle = Mid(sTxt, P1 + 3, 4)
Debug.Print sLittle
Select Case sLittle
Case "2248"
sReplace = "ALMOST EQUAL"
Case "2220"
sReplace = "ANGLE"
Case "2104"
sReplace = "CENTER LINE"
Case "0394"
sReplace = "DELTA"
Case "0278"
sReplace = "ELECTRIC PHASE"
Case "E101"
sReplace = "FLOW LINE"
Case "2261"
sReplace = "IDENTITY"
Case "E200"
sReplace = "INITIAL LENGTH"
Case "E102"
sReplace = "MONUMENT LINE"
Case "2260"
sReplace = "NOT EQUAL"
Case "2126"
sReplace = "OHM"
Case "03A9"
sReplace = "OMEGA"
Case "214A"
sReplace = "PROPERTY LINE"
Case "2082"
sReplace = "SUBSCRIPT2"
Case "00B2"
sReplace = "SQUARED"
Case "00B3"
sReplace = "CUBED"
End Select
sTxt = Replace(sTxt, "\U+" & sLittle, sReplace)
Case "\~"
sTxt = Replace(sTxt, "\~", " ")
Case "\\"
iStart = P1 + 2
sTxt = Replace(sTxt, "\\", "\")
GoTo Selectagain
Case "\P"
iStart = P1 + 1
GoTo Selectagain
Case Else
Exit Do
End Select
Selectagain:
Loop
'------------------------------------------------------------------------------
'Replace \P with vbCrLf
'------------------------------------------------------------------------------
Do
P1 = InStr(1, sTxt, "\P", vbTextCompare)
If P1 = 0 Then
Exit Do
Else
sTxt = Left(sTxt, P1 - 1) & vbCrLf & Mid(sTxt, P1 + 2)
End If
Loop
For iStart = 0 To 1
If iStart = 0 Then
sComp = "}"
Else
sComp = "{"
End If
P2 = InStr(1, sTxt, sComp)
Do While P2 > 0
sTxt = Left(sTxt, P2 - 1) & Mid(sTxt, P2 + 1)
P2 = InStr(1, sTxt, sComp)
Loop
Next iStart
MText_Unformat = sTxt
End Function
