[原创]获取MText中的可用字符
Public Function LeftStr(ByVal String1 As Variant, ByVal String2 As Variant)On Error Resume Next
LeftStr = Left(String1, InStr(String1, String2) - 1)
If Err Then LeftStr = ""
End Function
Public Function RightStr(ByVal String1 As Variant, ByVal String2 As Variant)
On Error Resume Next
RightStr = Right(String1, Len(String1) - Len(String2) - InStr(String1, String2) + 1)
If Err Then RightStr = ""
End Function
Public Function GetMTextString(str As String) As String
Dim pStrs As New Collection
Dim pStr As String, pType As String
Dim i, j
Dim pNum As Integer
pNum = InStr(str, "{")
Do While pNum > 0
If pNum = 1 Then
pStrs.Add RightStr(LeftStr(str, "}"), "{")
str = RightStr(str, "}")
Else
pStrs.Add LeftStr(str, "{")
str = "{" & RightStr(str, "{")
End If
pNum = InStr(str, "{")
Loop
If Trim(str) <> "" Then pStrs.Add str
For Each i In pStrs
For Each j In Split(i, "\")
If InStr(i, "\") > 0 Then
pType = Left(j, 1)
If pType = "f" Or pType = "F" Or pType = "c" Or pType = "C" Then
pStr = pStr & RightStr(j, ";")
Else
pStr = pStr & RightStr(j, Mid(j, 1, 1))
End If
Else
pStr = pStr & i
End If
Next j
Next i
GetMTextString = pStr
End Function
非常精彩，可惜没有lisp版本的 我也正在找lisp版 不用那么麻烦，炸开取单行文件的字符串的就可以了。 是麻烦点，不过总觉得炸开取字符串不保险，如果用户来个取消，不知道到哪一步了
不过还没有考虑\s、\h、\u、\b这几种情况 本帖最后由 作者 于 2004-6-25 23:29:37 编辑
这是改进版，已基本解决问题，欢迎测试Public Function FindStr(ByVal str As Variant, ByVal Target As Variant)
str = Replace(str, "\\", "**")
str = Replace(str, "\" & Target, "**")
FindStr = InStr(str, Target)
End FunctionPublic Function LeftStr(ByVal String1 As Variant, ByVal String2 As Variant)
On Error Resume Next
LeftStr = Left(String1, FindStr(String1, String2) - 1)
If Err Then LeftStr = ""
End FunctionPublic Function RightStr(ByVal String1 As Variant, ByVal String2 As Variant)
On Error Resume Next
RightStr = Right(String1, Len(String1) - Len(String2) - FindStr(String1, String2) + 1)
If Err Then RightStr = ""
End FunctionPublic Function FindMirrorString(ByVal str As String, ByVal StartStr As String, ByVal EndStr As String) As Integer
Dim pStart As Integer, pEnd As Integer
Dim pSNum As Integer, pENum As Integer
FindMirrorString = FindStr(str, StartStr)
If FindMirrorString = 0 Then Exit Function
FindMirrorString = 0
Do While pStart = 0 Or pEnd = 0 Or pStart <> pEnd
pSNum = FindStr(str, StartStr): pENum = FindStr(str, EndStr)
If pENum = 0 Then
FindMirrorString = 0: Exit Function
ElseIf pSNum < pENum And pSNum <> 0 Then
pStart = pStart + 1
FindMirrorString = FindMirrorString + pSNum
str = RightStr(str, StartStr)
Else
pEnd = pEnd + 1
FindMirrorString = FindMirrorString + pENum
str = RightStr(str, EndStr)
End If
Loop
End FunctionPublic Function SplitMTextString(ByVal str As String, ByVal StartStr As String, ByVal EndStr As String) As Collection
On Error Resume Next
Dim pStr As String
Dim pStrs As New Collection
Dim pStart As Integer
Dim pEnd As Integer
Dim pNum As Integer
pNum = FindStr(str, StartStr)
If pNum = 0 Then
GoTo EndHandle
ElseIf pNum > 1 Then
pStrs.Add LeftStr(str, StartStr)
str = "{" & RightStr(str, StartStr)
End If
pNum = 1
Do While pNum > 0
pStart = pNum
pEnd = FindMirrorString(str, StartStr, EndStr)
If FindStr(str, StartStr) > 0 Then pStrs.Add LeftStr(str, StartStr)
pStr = Mid(str, pStart + 1, pEnd - pStart - 1)
For Each i In SplitMTextString(pStr, StartStr, EndStr)
pStrs.Add i
Next i
Err.Clear
str = Right(str, Len(str) - pEnd)
pNum = FindStr(str, StartStr)
Loop
EndHandle:
pStrs.Add str
Set SplitMTextString = pStrs
End FunctionPublic Function SplitRtfString(ByVal str As String) As Collection
Dim pSplit As Variant
Dim pStr As String
Dim pStrs As New Collection
Dim i As Integer
If str = "" Then GoTo EndHandle
str = "L" & str
pSplit = Split(str, "\")
i = 0
Do While i <= UBound(pSplit)
If pSplit(i) = "" Then
If pStrs.Count > 0 Then
pStr = pStrs(pStrs.Count)
pStrs.Remove pStrs.Count
End If
pStrs.Add pStr & "\" & pSplit(i + 1)
i = i + 1
ElseIf Asc(pSplit(i)) = 123 Or Asc(pSplit(i)) = 125 Then
If pStrs.Count > 0 Then
pStr = pStrs(pStrs.Count)
pStrs.Remove pStrs.Count
End If
pStrs.Add pStr & pSplit(i)
Else
pStrs.Add pSplit(i)
End If
i = i + 1
Loop
EndHandle:
Set SplitRtfString = pStrs
End Function
Public Function GetMTextString(str As String) As String
Dim pStr As String, pType As Long
Dim i, j
For Each i In SplitMTextString(str, "{", "}")
For Each j In SplitRtfString(i)
If CStr(UCase(Left(j, 1))) <> "" Then
pType = Asc(CStr(UCase(Left(j, 1))))
Select Case pType
Case 65, 67, 70, 72, 81, 84, 87 'A/C/F/H/Q/T/W
pStr = pStr & RightStr(j, ";")
Case 76, 79, 80 'L/O/P
pStr = pStr & RightStr(j, Left(j, 1))
Case 83 'S
j = Mid(j, 2, Len(j) - 2)
pStr = pStr & Replace(j, "^", "")
Case 85 'U
pStr = pStr & "\" & j
Case 126 '~
pStr = pStr & Replace(j, "~", " ")
Case Else
pStr = pStr & j
End Select
End If
Next j
Next i
GetMTextString = pStr
End Function 什么叫 <b>MText中的可用字符 ???</b> 引用以下控件后，就可以用以下程序来做。
详细就留给飞狐版主完善了。应该说使用这个控件使程序更加简单 Sub MtToDt()
Dim s As String
Dim RE As RegExp
Set RE = New RegExp
RE.IgnoreCase = True
RE.Global = True
s = "\A1;明{\H2.4x;经通}道{\fTimes|b0|i0|c0|p18;http://www.mjtd.com}是\P一个{\H0.6978x;\S好^网站;}啊，{\L呵呵}"
'处理文字大小
RE.Pattern = "\{\\H(.[^;}]*);(.[^}]*)\}"
s = RE.Replace(s, "$2")
'处理堆迭
RE.Pattern = "\\S(.[^;]*)\^(.[^;]*);"
s = RE.Replace(s, "$1$2")
'处理字体
RE.Pattern = "\{\\f(.[^}]*);(.[^}]*)\}"
s = RE.Replace(s, "$2")
'处理文字首位置字符
RE.Pattern = "\\A(.[^}]*);"
s = RE.Replace(s, "")
'处理下划线
RE.Pattern = "\{\\L(.[^;}]*)\}"
s = RE.Replace(s, "$1")
'处理换行符
RE.Pattern = "\\P"
s = RE.Replace(s, "")
Debug.Print s
Set RE = Nothing
End Sub
处理完后就剩下这一部分了：明经通道http://www.mjtd.com是一个好网站啊，呵呵
可是RTF最多有8层嵌套RegExp是怎么处理的呢 确实得详细考虑嵌套关系 本帖最后由 作者 于 2004-6-23 23:03:12 编辑
可能还是要找到镜像字符对，好像和我的程序差不多了？
或者用堆栈直接处理应该简单一点吧 <A name=29425><FONT color=#990000><B>lzh741206</B></FONT></A>能否提供一个复杂的MTEXT格式的样例用于调试程序用。