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

雪山飞狐(lzh)

Public function FindStr(ByVal Str As Variant, ByVal Target As Variant)
'屏蔽“\”号“{”号及“}”号，返回Target在字符串中的位置
    Str = Replace(Str, "\\", "**")
    Str = Replace(Str, "\" & Target, "**")
    FindStr = InStr(Str, Target)
End Function

Public function LeftStr(ByVal String1 As Variant, ByVal String2 As Variant)
'获取在字符串String1第一个String2的左边的子字符串
On Error Resume Next
    LeftStr = Left(String1, FindStr(String1, String2) - 1)
    If Err Then LeftStr = ""
End Function

Public function RightStr(ByVal String1 As Variant, ByVal String2 As Variant)
'获取在字符串String1第一个String2的右边的子字符串
On Error Resume Next
    RightStr = Right(String1, Len(String1) - Len(String2) - FindStr(String1, String2) + 1)
    If Err Then RightStr = ""
End Function

Public function FindMirrorString(ByVal Str As String, ByVal StartStr As String, ByVal EndStr As String) As Integer
'寻找StartStr的镜像字符EndStr 的位置，并返回
    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 Function

Public function SplitMTextString(ByVal Str As String, ByVal StartStr As String, ByVal EndStr As String) As Collection
'将Mtest简单的分解为集合，去除"{"号和"}"号
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 Function

Public function SplitRtfString(ByVal Str As String) As Collection
'分解Rtf字符串
    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
'获取MText的TextString并返回可用的字符
    Dim pStr As String, pType As Integer
    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                                             'A
                    pStr = pStr & RightStr(j, ";")
                Case 67                                             'C
                    pStr = pStr & RightStr(j, ";")
                Case 70                                             'F
                    pStr = pStr & RightStr(j, ";")
                Case 72                                             'H
                    pStr = pStr & RightStr(j, ";")
                Case 76                                             'L
                    pStr = pStr & RightStr(j, Left(j, 1))
                Case 79                                             '0
                    pStr = pStr & RightStr(j, Left(j, 1))
                Case 80                                             'P
                    pStr = pStr & RightStr(j, Left(j, 1))
                Case 81                                             'Q
                    pStr = pStr & RightStr(j, ";")
                Case 83                                             'S
                    j = Mid(j, 2, Len(j) - 2)
                    pStr = pStr & Replace(j, "^", "")
                Case 84                                             'T
                    pStr = pStr & RightStr(j, ";")
                Case 85                                             'U
                    pStr = pStr & "\" & j
                Case 87                                             'W
                    pStr = pStr & RightStr(j, ";")
                Case 126                                            '~
                    pStr = pStr & Replace(j, "~", " ")
                Case Else
                    pStr = pStr & j
                End Select
            End If
        Next j
    Next i
   
    GetMTextString = pStr
End Function