topic Re: Help me with mtexts and text string in VBA Forum

Help me with mtexts and text string

Anonymous — Sun, 02 Mar 2008 12:30:04 GMT

I want to iterate through the mtexts of a given drawing and export them to Excel.suppose that there is an mtext in the drawing named mtextobj in which "sample" is written in the first line and "note" is written in the 2nd.this would be read as "sample note". i use TextString property:
.
.
Dim mtextobj As AcadMText
MsgBox mtextobj .TextString
.
.
and autocad returns "sample\Pnote". this is appropriate for me.
the problem is when text formatting of this mtext is changed.for example if i double click on the mtext and in the Text Formatting box change the color to red,autocad returns
{\C1;sample\Pnote}

or if i change the font to verdana it gives
{\fVerdana|b0|i0|c0|p34;sample\fVerdana|b0|i0|c178|p34;\P\fVerdana|b0|i0|c0|p34;note}

How can i access to the real content inside the mtext? and get rid of this string which is merged with text formatting data?
any help is highly appreciated... Message was edited by: arman88

Re: Help me with mtexts and text string

Anonymous — Sun, 02 Mar 2008 15:21:12 GMT

Try this one

Option Explicit
' written by Bryco

Function UnformatMtext(S As String) As String

Dim P1 As Integer
Dim P2 As Integer, P3 As Integer
Dim intStart As Integer
Dim strCom As String
Dim strReplace As String

Debug.Print S

Select Case Left(S, 4)
Case "\A0;", "\A1;", "\A2;"
S = Mid(S, P1 + 5)
End Select
intStart = 1
Do
P1 = InStr(S, "%%")
If P1 = 0 Then
Exit Do
Else
Select Case Mid(S, P1 + 2, 1)
Case "P"
S = Replace(S, "%%P", "+or-")
Case "D"
S = Replace(S, "%%D", " deg")
End Select
End If
Loop

Do
P1 = InStr(intStart, S, "\", vbTextCompare)
If P1 = 0 Then Exit Do
strCom = Mid(S, P1, 2)
Select Case strCom
Case "\p"
P2 = InStr(1, S, ";")
S = Mid(S, P2 + 1)
Case "\A", "\C", "\f", "\F", "\H", "\Q", "\T", "\W"
P2 = InStr(P1 + 2, S, ";", vbTextCompare)
P3 = InStr(P1 + 2, S, strCom, vbTextCompare)
If P3 = 0 Then
S = Left(S, P1 - 1) & Mid(S, P2 + 1)
End If
Do While P3 > 0
P2 = InStr(P3, S, ";", vbTextCompare)
S = Left(S, P3 - 1) & Mid(S, P2 + 1)
'Debug.Print s, strCom
P3 = InStr(1, S, strCom, vbTextCompare)
Loop
's = Left(s, P3 - 1) & mid(s, P3 + 1)
'Case "\L", "\O"
'Dim strLittle As String
'strLittle = LCase(strCom)
'P2 = InStr(P1 + 2, S, strLittle, vbTextCompare)
'S = Left(S, P1 - 1) & Mid(S, P1 + 2, P2 - (P1 + 2)) & Mid(S, P2 + 2)
'//============== fixed by fla_2
'// example {\fArial|b1|i0|c0|p34;\LGENERAL NOTES :}
Case "\L", "\O"
Dim strLittle As String
strLittle = LCase(strCom)
P2 = InStr(P1 + 2, S, strLittle, vbTextCompare)
If P2 = 0 Then
S = Left(S, P1 - 1) & Mid(S, P1 + 2)
Else
S = Left(S, P1 - 1) & Mid(S, P1 + 2, P2 - (P1 + 2)) & Mid(S, P2 + 2)
End If
'//==============
Case "\S"
P2 = InStr(P1 + 2, S, ";", vbTextCompare)
P3 = InStr(P1 + 2, S, "/", vbTextCompare)
If P3 = 0 Or P3 > P2 Then
P3 = InStr(P1 + 2, S, "#", vbTextCompare)
End If
If P3 = 0 Or P3 > P2 Then
P3 = InStr(P1 + 2, S, "^", vbTextCompare)
End If
S = Left(S, P1 - 1) & Mid(S, P1 + 2, P3 - (P1 + 2)) _
& "/" & Mid(S, P3 + 1, (P2) - (P3 + 1)) & Mid(S, P2 + 1)

Case "\U"
strLittle = Mid(S, P1 + 3, 4)
Debug.Print strLittle
Select Case strLittle
Case "2248"
strReplace = "ALMOST EQUAL"
Case "2220"
strReplace = "ANGLE"
Case "2104"
strReplace = "CENTER LINE"
Case "0394"
strReplace = "DELTA"
Case "0278"
strReplace = "ELECTRIC PHASE"
Case "E101"
strReplace = "FLOW LINE"
Case "2261"
strReplace = "IDENTITY"
Case "E200"
strReplace = "INITIAL LENGTH"
Case "E102"
strReplace = "MONUMENT LINE"
Case "2260"
strReplace = "NOT EQUAL"
Case "2126"
strReplace = "OHM"
Case "03A9"
strReplace = "OMEGA"
Case "214A"
strReplace = "PROPERTY LINE"
Case "2082"
strReplace = "SUBSCRIPT2"
Case "00B2"
strReplace = "SQUARED"
Case "00B3"
strReplace = "CUBED"

End Select
S = Replace(S, "\U+" & strLittle, strReplace)

Case "\~"
S = Replace(S, "\~", " ")

Case "\\"
intStart = P1 + 2
S = Replace(S, "\\", "\")
GoTo Selectagain

Case "\P"
intStart = P1 + 1
GoTo Selectagain
Case Else
Exit Do
End Select
Selectagain:
Loop

Do
P1 = InStr(1, S, "\P", vbTextCompare)
If P1 = 0 Then
Exit Do
Else
S = Left(S, P1 - 1) & vbCrLf & Mid(S, P1 + 2)
End If
Loop
For intStart = 0 To 1
If intStart = 0 Then
strCom = "}"
Else
strCom = "{"
End If
P2 = InStr(1, S, strCom)

Do While P2 > 0
S = Left(S, P2 - 1) & Mid(S, P2 + 1)
P2 = InStr(1, S, strCom)
Loop
Next intStart

UnformatMtext = S

End Function

Sub Testmt()
Dim Mt As AcadMText, V As Variant
ThisDrawing.Utility.GetEntity Mt, V, "Pick an Mtext:"
Debug.Print Mt.textString
Mt.textString = UnformatMtext(Mt.textString)
MsgBox Mt.textString
End Sub

Re: Help me with mtexts and text string

Anonymous — Mon, 03 Mar 2008 11:39:29 GMT

WOWWWWW . Thanksssss a lot! That works pretty well. I used that function and this code:

Sub Testmt()
Dim Mt As AcadMText
Dim obj As AcadObject
For Each obj In ThisDrawing.ModelSpace
If obj.ObjectName = "AcDbMText" Then
Set Mt = obj
Debug.Print Mt.TextString
Mt.TextString = UnformatMtext(Mt.TextString)
End If
Next
End Sub

This way all mtexts in the drawing corrected in the way i want.It dosn't change boundaries, size , insertion point,attachmentpoint and layer of mtexts. right? because I want those properties to be left original.I checked and it seems ok.

Thanks again Fatty! and Thanks Bryco!

Re: Help me with mtexts and text string

Anonymous — Mon, 03 Mar 2008 12:33:21 GMT

Yeah, thanks Bryco

~'J'~

Re: Help me with mtexts and text string

Anonymous — Tue, 04 Mar 2008 09:45:11 GMT

i found lisp code for that too.
try .lsp and .dcl in the attachments