本帖最后由 作者 于 2004-6-24 22:06:23 编辑 <br /><br /> 试试这个：
{\C3;明经通{\fSimSun|b0|i0|c134|p2;道}\Lhttp://www.mjtd.com{\C3;明经通道\Lhtt\C1;p://www.mj\C3;td.com\l是一个好网站啊，呵呵}<BR>\l是\Ftxt.shx,gbcbig.shx|c134;一个好网站啊，呵呵}
返回 明经通道<A href="http://www.mjtd.com/" target="_blank" >http://www.mjtd.com</A>明经通道<A href="http://www.mjtd.com/" target="_blank" >http://www.mjtd.com</A>是一个好网站啊，呵呵是一个好网站啊，呵呵
再一个
"{\C3;明经通{\fSimSun|b0|i0|c134|p2;道}\Lhttp://www.mjtd.com{\C3;明经通道\Lhttp{\C1;://{\C3;www}.mjtd.com}\l是一个好网站啊，呵呵}\l是{\Ftxt.shx,gbcbig.shx|c134;一个好网站}啊，呵呵}"
已经写出来了，试用中：Sub MtToDt()
Dim s As String
's = ThisDrawing.ModelSpace(0).TextString
s = "{\C3;明经通{\fSimSun|b0|i0|c134|p2;道}\Lhttp://www.mjtd.com{\C3;明经通道\Lhttp{\C1;://{\C3;www}.mjtd.com}\l是一个好网站啊，呵呵}\l是{\Ftxt.shx,gbcbig.shx|c134;一个好网站}啊，呵呵}"
Debug.Print s
s = GetMTextUnformatString(s)
Debug.Print s
End Sub
Public Function GetMTextUnformatString(MTextString As String) As String
Dim s As String
Dim RE As RegExp
Set RE = New RegExp
RE.IgnoreCase = True
RE.Global = True
s = MTextString
'替换\\字符
RE.Pattern = "\\\\"
s = RE.Replace(s, Chr(1))
'删除堆迭格式
RE.Pattern = "\\S(.[^;]*)(\^|#|\\)(.[^;]*);"
s = RE.Replace(s, "$1$3")
'删除字体、颜色、字高、字距、倾斜、字宽、对齐格式
RE.Pattern = "(\\F|\\C|\\H|\\T|\\Q|\\W|\\A)(.[^;]*);"
s = RE.Replace(s, "")
'删除下划线、删除线格式
RE.Pattern = "(\\L|\\O)"
s = RE.Replace(s, "")
'删除不间断空格格式
RE.Pattern = "\\~"
s = RE.Replace(s, " ")
'删除换行符格式
RE.Pattern = "\\P"
s = RE.Replace(s, "")
'删除{}
RE.Pattern = "({|})"
s = RE.Replace(s, "")
'替换回\\字符
RE.Pattern = "\x01"
s = RE.Replace(s, "\\")
Set RE = Nothing
GetMTextUnformatString = s
End Function
"{\C3;明经通{\fSimSun|b0|i0|c134|p2;道}\L\{http://www.mjtd.com\}{\C3;明经通道\Lhttp{\C1;://{\C3;www}.mjtd.com}\l是一个好网站啊，呵呵}\l是{\Ftxt.shx,gbcbig.shx|c134;一个好网站}啊，呵呵}"
这个例子不行，好像没有考虑 "\{"和"\}"
不过我的好像把"{}"都丢了
下面的是用栈实现的，Public Function GetMTextUnformatString(ByVal str As String) As String
On Error Resume Next
Dim pStrs As New Collection
Dim pStrack As String
Dim n As Integer
Dim pStr As String
Dim pEnd As String
Do While Len(str) > 0
n = IIf(Left(str, 1) = "\", 2, 1)
pStr = Left(str, n)
If pStr = "}" Then
pEnd = pStrs(pStrs.Count)
pStrack = ""
Do While pEnd <> "{"
pStrack = pEnd & pStrack
pStrs.Remove pStrs.Count
pEnd = pStrs(pStrs.Count)
Loop
pStrs.Remove pStrs.Count
pStrs.Add GetRtfStrig(pStrack)
Else
pStrs.Add Left(str, n)
End If
str = Right(str, Len(str) - n)
Loop
For Each i In pStrs
GetMTextUnformatString = GetMTextUnformatString & i
Next i
End Function
Private Function GetRtfStrig(ByVal str As String) As String
Dim s As String
Dim RE As RegExp
Set RE = New RegExp
RE.IgnoreCase = True
RE.Global = True
s = str
'替换\\字符
RE.Pattern = "\\\\"
s = RE.Replace(s, Chr(1))
'删除堆迭格式
RE.Pattern = "\\S(.[^;]*)(\^|#|\\)(.[^;]*);"
s = RE.Replace(s, "$1$3")
'删除字体、颜色、字高、字距、倾斜、字宽、对齐格式
RE.Pattern = "(\\F|\\C|\\H|\\T|\\Q|\\W|\\A)(.[^;]*);"
s = RE.Replace(s, "")
'删除下划线、删除线格式
RE.Pattern = "(\\L|\\O)"
s = RE.Replace(s, "")
'删除不间断空格格式
RE.Pattern = "\\~"
s = RE.Replace(s, " ")
'删除换行符格式
RE.Pattern = "\\P"
s = RE.Replace(s, "")
'替换{}
RE.Pattern = "\\{"
s = RE.Replace(s, "{")
RE.Pattern = "\\}"
s = RE.Replace(s, "}")
'替换回\\字符
RE.Pattern = "\x01"
s = RE.Replace(s, "\\")
Set RE = Nothing
GetRtfStrig = sEnd Function替换前："{\C3;\{明经通{\fSimSun|b0|i0|c134|p2;道\}}\Lhttp://www.mjtd.com{\C3;明经通道\Lhttp{\C1;://{\C3;www}.mjtd.com}\l是一个好网站啊，呵呵}\l是{\Ftxt.shx,gbcbig.shx|c134;一个好网站}啊，呵呵}"替换后：{明经通道}http://www.mjtd.com明经通道http://www.mjtd.com是一个好网站啊，呵呵是一个好网站啊，呵呵
Public Function GetMTextUnformatString(MTextString As String) As String
Dim s As String
Dim RE As RegExp
Set RE = New RegExp
RE.IgnoreCase = True
RE.Global = True
s = MTextString
'替换\\字符
RE.Pattern = "\\\\"
s = RE.Replace(s, Chr(1))
'替换\{字符
RE.Pattern = "\\{"
s = RE.Replace(s, Chr(2))
'替换\}字符
RE.Pattern = "\\}"
s = RE.Replace(s, Chr(3))
'删除堆迭格式
RE.Pattern = "\\S(.[^;]*)(\^|#|\\)(.[^;]*);"
s = RE.Replace(s, "$1$3")
'删除字体、颜色、字高、字距、倾斜、字宽、对齐格式
RE.Pattern = "(
本帖最后由 作者 于 2004-6-25 20:57:51 编辑 <br /><br /> 如果故意挑点刺的话，下面的测试用例好像有点问题
s = "{\C3;\{明经通{\fSimSun|b0|i0|c134|p2;道\}}\Lhttp://www.mjtd.com{\C3;明经通道\Lhttp{\C1;://{\C3;www}.mjtd.com}\l是一个好网站啊，呵呵}\l是{\Ftxt.shx,gbcbig.shx|c134;一个好网站}啊，" & Chr(3) & "呵呵}"<BR>
不过我的代码好像也有点问题，改进中。。。
不错，是有问题，但实际是不可能出现的，因为该字符没有实际意义，通过用户的输入也不可能出现这样的字符，所以不需要考虑这种情况。
由于AutoCAD没有把分号做为识别符，所以用分号来堆迭会出现异常。所以这里没有把多行文字中的分号做特别处理。<BR>应该说这个程序已经满足要求了。
本帖最后由 作者 于 2004-6-27 13:00:15 编辑
我又改进了一下，下面的程序基本可用。3楼的代码又重写了一遍Public Function GetMTextUnformatString(ByVal str As String) As String
'程序功能:按给定的MText字符串返回可用的字符串
On Error Resume Next Dim pStrs As New Collection
Dim pStack As Collection
Dim n As Integer
Dim pStr As String
Dim pEnd As String
str = "{" & str & "}"
Do While Len(str) > 0
n = IIf(Left(str, 1) = "\", 2, 1)
pStr = Left(str, n)
'分割MText字符串为控制字符或单个字符
If pStr = "}" Then
'遇"}"时出栈，直到"{"
pEnd = pStrs(pStrs.Count)
Set pStack = New Collection
pStack.Add "*TlsCad*"
Do While pEnd <> "{"
pStack.Add pEnd, , 1
pStrs.Remove pStrs.Count
pEnd = pStrs(pStrs.Count)
Loop
pStrs.Remove pStrs.Count
pStack.Remove pStack.Count
For Each i In GetRtfString(pStack)
'调用GetRtfString函数返回可用的字符集合
pStrs.Add i
Next i
Else
'当前字符入栈
pStrs.Add Left(str, n)
End If
str = Right(str, Len(str) - n)
Loop
For Each i In pStrs
'合并字符集合为字符串
If Len(i) = 2 Then
'处理\、{、}
GetMTextUnformatString = GetMTextUnformatString & Right(i, 1)
Else
GetMTextUnformatString = GetMTextUnformatString & i
End If
Next i
End FunctionPrivate Function GetRtfString(ByVal stack As Collection) As Collection
'程序功能:按给定的Rtf字符集合返回可用的字符集合 Dim pStrs As New Collection
Dim pStr As String, pType As Long
Dim i, j
For Each i In stack
If Len(i) = 1 Then
pStrs.Add i
ElseIf Len(i) = 2 Then
pType = Asc(UCase(Right(i, 1)))
Select Case pType
Case 85, 92, 123, 125
'\ or { or } or U
pStrs.Add i
Case 65, 67, 70, 72, 81, 84, 87
'A or C or F or H or Q or T or W
Do While stack(1) <> ";"
stack.Remove 1
Loop
stack.Remove 1
Case 76, 79, 80
'L or O or P
Case 83
'S
stack.Remove 1
Do While stack(1) <> ";"
If stack(1) <> "^" Then
pStrs.Add stack(1)
End If
stack.Remove 1
Loop
stack.Remove 1
Case 126
'~
pStrs.Add " "
End Select
End If
Next i Set GetRtfString = pStrs
End Function
意犹未尽，再来段VB.Net的 '程序功能：返回MText中的可用字符串
Public Function GetMTextUnFormatString(ByVal str As String) As String
Dim pQueue As System.Collections.Queue
Dim pSubStack As System.Collections.Stack
Dim pStack As New System.Collections.Stack
Dim pNum As Short
Dim pStr, i As String
Try
str = "{" & str & "}"
'将MText字符串分割为控制符和单个字符
Do While str.Length > 0
pNum = IIf(str.Substring(0, 1) = "\", 2, 1)
'当前字符为"}"时顺序出栈，直到遇到第一个"{"
If pNum = 1 And str.Substring(0, 1) = "}" Then
pSubStack = New System.Collections.Stack
Do While Convert.ToString(pStack.Peek()) <> "{"
pSubStack.Push(pStack.Pop())
Loop
pStack.Pop()
'调用GetRtfTextUnFormatString函数返回Rtf字符栈中的可用字符队列
pQueue = GetRtfTextUnFormatString(pSubStack)
'将可用字符队列顺序入栈
Do While pQueue.Count > 0
pStack.Push(pQueue.Dequeue)
Loop
Else
'当前字符入栈
pStack.Push(str.Substring(0, pNum))
End If
str = str.Substring(pNum)
Loop '返回栈中的可用字符串
For Each i In pStack.ToArray
If i.Length = 1 Then
pStr = i & pStr
ElseIf i.Length = 2 Then
pStr = i.Substring(1, 1) & pStr
End If
Next i
Return pStr
Catch ex As Exception
Return ""
End Try End Function '程序功能：返回Rtf字符栈中的可用字符队列
Private Function GetRtfTextUnFormatString(ByVal stack As System.Collections.Stack) As System.Collections.Queue
Dim i As Object
Dim pStr As String
Dim pQueue As New System.Collections.Queue
Try
'顺序出栈
Do While stack.Count > 0
pStr = Convert.ToString(stack.Pop)
'当前的单个字符入队
If pStr.Length = 1 Then
pQueue.Enqueue(pStr)
Else
'处理控制字符
Select Case pStr.Substring(1, 1).ToUpper
Case "\", "{", "}", "U"
pQueue.Enqueue(pStr)
Case "A", "C", "F", "H", "Q", "T", "W"
Do While Convert.ToString(stack.Pop()) <> ";"
Loop
Case "L", "O", "P"
Case "S"
Do While Convert.ToString(stack.Peek()) <> ";"
If stack.Peek <> "^" Then
pQueue.Enqueue(stack.Pop())
Else
stack.Pop()
End If
Loop
stack.Pop()
Case "~"
pQueue.Enqueue(" ")
End Select
End If
Loop
Catch ex As Exception
End Try
Return pQueue
End Function