[原创]获取MText中的可用字符

雪山飞狐_lzh

2. Public Function LeftStr(ByVal String1 As Variant, ByVal String2 As Variant)
3. On Error Resume Next
4.     LeftStr = Left(String1, InStr(String1, String2) - 1)
5.     If Err Then LeftStr = ""
6. End Function
8. Public Function RightStr(ByVal String1 As Variant, ByVal String2 As Variant)
9. On Error Resume Next
10.     RightStr = Right(String1, Len(String1) - Len(String2) - InStr(String1, String2) + 1)
11.     If Err Then RightStr = ""
12. End Function
14. Public Function GetMTextString(str As String) As String
15.     Dim pStrs As New Collection
16.     Dim pStr As String, pType As String
17.     Dim i, j
18.     Dim pNum As Integer
19.     pNum = InStr(str, "{")
20.     Do While pNum > 0
21.         If pNum = 1 Then
22.             pStrs.Add RightStr(LeftStr(str, "}"), "{")
23.             str = RightStr(str, "}")
24.         Else
25.             pStrs.Add LeftStr(str, "{")
26.             str = "{" & RightStr(str, "{")
27.         End If
28.         pNum = InStr(str, "{")
29.     Loop
30.     If Trim(str) <> "" Then pStrs.Add str
31.     For Each i In pStrs
32.         For Each j In Split(i, "")
33.             If InStr(i, "") > 0 Then
34.                 pType = Left(j, 1)
35.                 If pType = "f" Or pType = "F" Or pType = "c" Or pType = "C" Then
36.                     pStr = pStr & RightStr(j, ";")
37.                 Else
38.                     pStr = pStr & RightStr(j, Mid(j, 1, 1))
39.                 End If
40.             Else
41.                 pStr = pStr & i
42.             End If
43.         Next j
44.     Next i
45.     GetMTextString = pStr
46. End Function

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

jack093

非常精彩，可惜没有lisp版本的

yaokui25

我也正在找lisp版

mccad

不用那么麻烦，炸开取单行文件的字符串的就可以了。

雪山飞狐_lzh

是麻烦点，不过总觉得炸开取字符串不保险，如果用户来个取消，不知道到哪一步了


不过还没有考虑\s、\h、\u、\b这几种情况

雪山飞狐_lzh

这是改进版，已基本解决问题，欢迎测试

2. Public Function FindStr(ByVal str As Variant, ByVal Target As Variant)
3.        str = Replace(str, "\", "**")
4.        str = Replace(str, "" & Target, "**")
5.        FindStr = InStr(str, Target)
6. End FunctionPublic Function LeftStr(ByVal String1 As Variant, ByVal String2 As Variant)
7. On Error Resume Next
8.        LeftStr = Left(String1, FindStr(String1, String2) - 1)
9.        If Err Then LeftStr = ""
10. End FunctionPublic Function RightStr(ByVal String1 As Variant, ByVal String2 As Variant)
11. On Error Resume Next
12.        RightStr = Right(String1, Len(String1) - Len(String2) - FindStr(String1, String2) + 1)
13.        If Err Then RightStr = ""
14. End FunctionPublic Function FindMirrorString(ByVal str As String, ByVal StartStr As String, ByVal EndStr As String) As Integer
15.        Dim pStart As Integer, pEnd As Integer
16.        Dim pSNum As Integer, pENum As Integer
17.        FindMirrorString = FindStr(str, StartStr)
18.        If FindMirrorString = 0 Then Exit Function
19.        FindMirrorString = 0
20.        Do While pStart = 0 Or pEnd = 0 Or pStart <> pEnd
21.                pSNum = FindStr(str, StartStr): pENum = FindStr(str, EndStr)
22.                If pENum = 0 Then
23.                        FindMirrorString = 0: Exit Function
24.                ElseIf pSNum < pENum And pSNum <> 0 Then
25.                        pStart = pStart + 1
26.                        FindMirrorString = FindMirrorString + pSNum
27.                        str = RightStr(str, StartStr)
28.                Else
29.                        pEnd = pEnd + 1
30.                        FindMirrorString = FindMirrorString + pENum
31.                        str = RightStr(str, EndStr)
32.                End If
33.        Loop
34. End FunctionPublic Function SplitMTextString(ByVal str As String, ByVal StartStr As String, ByVal EndStr As String) As Collection
35. On Error Resume Next
36.        Dim pStr As String
37.        Dim pStrs As New Collection
38.        Dim pStart As Integer
39.        Dim pEnd As Integer
40.        Dim pNum As Integer
41.        pNum = FindStr(str, StartStr)
42.        If pNum = 0 Then
43.                GoTo EndHandle
44.        ElseIf pNum > 1 Then
45.                pStrs.Add LeftStr(str, StartStr)
46.                str = "{" & RightStr(str, StartStr)
47.        End If
48.        pNum = 1
49.        Do While pNum > 0
50.                pStart = pNum
51.                pEnd = FindMirrorString(str, StartStr, EndStr)
52.                If FindStr(str, StartStr) > 0 Then pStrs.Add LeftStr(str, StartStr)
53.                pStr = Mid(str, pStart + 1, pEnd - pStart - 1)
54.                        For Each i In SplitMTextString(pStr, StartStr, EndStr)
55.                                pStrs.Add i
56.                        Next i
57.                Err.Clear
58.                str = Right(str, Len(str) - pEnd)
59.                pNum = FindStr(str, StartStr)
60.        Loop
61. EndHandle:
62.        pStrs.Add str
63.        Set SplitMTextString = pStrs
64. End FunctionPublic Function SplitRtfString(ByVal str As String) As Collection
65.        Dim pSplit As Variant
66.        Dim pStr As String
67.        Dim pStrs As New Collection
68.        Dim i As Integer
69.        If str = "" Then GoTo EndHandle
70.        str = "L" & str
71.        pSplit = Split(str, "")
72.        i = 0
73.        Do While i <= UBound(pSplit)
74.        If pSplit(i) = "" Then
75.                If pStrs.Count > 0 Then
76.                        pStr = pStrs(pStrs.Count)
77.                        pStrs.Remove pStrs.Count
78.                End If
79.                pStrs.Add pStr & "" & pSplit(i + 1)
80.                i = i + 1
81.        ElseIf Asc(pSplit(i)) = 123 Or Asc(pSplit(i)) = 125 Then
82.                If pStrs.Count > 0 Then
83.                        pStr = pStrs(pStrs.Count)
84.                        pStrs.Remove pStrs.Count
85.                End If
86.                pStrs.Add pStr & pSplit(i)
87.        Else
88.                pStrs.Add pSplit(i)
89.        End If
90.        i = i + 1
91.        Loop
92. EndHandle:
93.        Set SplitRtfString = pStrs
94. End Function
95. Public Function GetMTextString(str As String) As String
96.        Dim pStr As String, pType As Long
97.        Dim i, j
98.       
99.        For Each i In SplitMTextString(str, "{", "}")
100.                For Each j In SplitRtfString(i)
101.                        If CStr(UCase(Left(j, 1))) <> "" Then
102.                                pType = Asc(CStr(UCase(Left(j, 1))))
103.                                Select Case pType
104.                                Case 65, 67, 70, 72, 81, 84, 87                                         'A/C/F/H/Q/T/W
105.                                        pStr = pStr & RightStr(j, ";")
106.                                Case 76, 79, 80                                                                         'L/O/P
107.                                        pStr = pStr & RightStr(j, Left(j, 1))
108.                                Case 83                                                                                         'S
109.                                        j = Mid(j, 2, Len(j) - 2)
110.                                        pStr = pStr & Replace(j, "^", "")
111.                                Case 85                                                                                         'U
112.                                        pStr = pStr & "" & j
113.                                Case 126                                                                                       '~
114.                                        pStr = pStr & Replace(j, "~", " ")
115.                                Case Else
116.                                        pStr = pStr & j
117.                                End Select
118.                        End If
119.                Next j
120.        Next i
121.       
122.        GetMTextString = pStr
123. End Function

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

spring

什么叫 MText中的可用字符 ???

mccad

引用以下控件后，就可以用以下程序来做。
详细就留给飞狐版主完善了。应该说使用这个控件使程序更加简单  

2. Sub MtToDt()
3.        Dim s As String
4.        Dim RE As RegExp
5.        Set RE = New RegExp
6.        RE.IgnoreCase = True
7.        RE.Global = True
8.        s = "\A1;明{\H2.4x;经通}道{\fTimes|b0|i0|c0|p18;http://www.mjtd.com}是\P一个{\H0.6978x;\S好^网站;}啊，{\L呵呵}"
9.        '处理文字大小
10.        RE.Pattern = "\{\\H(.[^;}]*);(.[^}]*)\}"
11.        s = RE.Replace(s, "$2")
12.        '处理堆迭
13.        RE.Pattern = "\\S(.[^;]*)\^(.[^;]*);"
14.        s = RE.Replace(s, "$1$2")
15.        '处理字体
16.        RE.Pattern = "\{\\f(.[^}]*);(.[^}]*)\}"
17.        s = RE.Replace(s, "$2")
18.        '处理文字首位置字符
19.        RE.Pattern = "\\A(.[^}]*);"
20.        s = RE.Replace(s, "")
21.        '处理下划线
22.        RE.Pattern = "\{\\L(.[^;}]*)\}"
23.        s = RE.Replace(s, "$1")
24.        '处理换行符
25.        RE.Pattern = "\\P"
26.        s = RE.Replace(s, "")
27.        Debug.Print s
28.        Set RE = Nothing
29.       
30. End Sub

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

处理完后就剩下这一部分了：

1. 明经通道http://www.mjtd.com是一个好网站啊，呵呵

复制代码

雪山飞狐_lzh

可是RTF最多有8层嵌套RegExp是怎么处理的呢

mccad

确实得详细考虑嵌套关系

雪山飞狐_lzh

可能还是要找到镜像字符对，好像和我的程序差不多了？


或者用堆栈直接处理应该简单一点吧

mccad

lzh741206能否提供一个复杂的MTEXT格式的样例用于调试程序用。