mstrfun.bas

VB编写：与字符串有关的拆分、合并、转换、替换、测试函数模块

        Erase tStr
'MsgBox "in new,bytestostring," & DateDiff("s", Now, st) & ",len=" & (UBound(bytes) - LBound(bytes) + 1)
End Sub


Public Function TwoByteAsChar(ByVal bHigh As Byte, ByVal bLow As Byte, Optional rLen As Integer) As String
Dim rs As String
If bHigh > 127 And bLow > 127 Then
  rs = Chr(CLng("&H" & Hex(CLng(bHigh) * 256 + bLow)))
Else
  rs = Chr(bHigh) & Chr(bLow)
End If
TwoByteAsChar = rs
rLen = Len(rs)
End Function


Public Function IsValidHexString(ByVal hStr As String, Optional ByRef RslHexStr As String) As Boolean
Dim i As Long
  IsValidHexString = False
  RslHexStr = ""
  If hStr = "" Then
     Exit Function
  End If
  '
  Dim LastCh As String
  Dim ch As String
  Dim LastHexCh As String
  LastCh = "Z"
  LastHexCh = ""
  For i = 1 To Len(hStr)
     ch = Mid(hStr, i, 1)
     If Not (ch = " " Or IsHexChar(ch)) Then
        IsValidHexString = False
        RslHexStr = ""
        Exit Function
     Else
        If ch = " " Then
            If Len(LastHexCh) = 1 Then
               If (i - 2) <= 0 Then
                  LastHexCh = "0" & LastHexCh
               Else
                  If IsHexChar(Mid(hStr, i - 2, 1)) Then
                     LastHexCh = LastHexCh & "0"
                  Else
                     LastHexCh = "0" & LastHexCh
                  End If
               End If
            End If
        End If
        If Len(LastHexCh) = 2 Then
           RslHexStr = RslHexStr & LastHexCh
           LastHexCh = ""
        End If
        If ch <> " " Then
           LastHexCh = LastHexCh & ch
        End If
     End If
     LastCh = ch
  Next i
  '
  If Len(LastHexCh) = 2 Then
     RslHexStr = RslHexStr & LastHexCh
     LastHexCh = ""
  Else
     If Len(LastHexCh) = 1 Then
        If (i - 2) <= 0 Then
           LastHexCh = "0" & LastHexCh
        Else
           If IsHexChar(Mid(hStr, i - 2, 1)) Then
              LastHexCh = LastHexCh & "0"
           Else
              LastHexCh = "0" & LastHexCh
           End If
        End If
        RslHexStr = RslHexStr & LastHexCh
     End If
  End If
  IsValidHexString = True
End Function

Public Function IndexOfArrayAtom(ByVal atomV As Variant, ByVal srcArray As Variant) As Long
'返回索引值以1为下界
Dim i As Long
IndexOfArrayAtom = -1
For i = LBound(srcArray) To UBound(srcArray)
  If srcArray(i) = atomV Then
    IndexOfArrayAtom = i - LBound(srcArray) + 1
    Exit Function
  End If
Next i
End Function

Public Sub DeCodeBytes(sBytes() As Byte, mode As Integer, ByVal oprs As Variant, ByRef proedBytes() As Byte, Optional ByRef proedStr As String, Optional DispProgress As Boolean = False)
Dim beProStr As String
Dim oprStr As String
Dim Lines() As String
  If mode = DECODE_ORIGINMODE Or IsNull(oprs) Or IsEmpty(oprs) Then
    proedBytes = sBytes
    If Not IsMissing(proedStr) Then
       SetBytesToString sBytes, 5, proedStr
    End If
  Else
    Dim i As Integer
    Dim j As Integer
    Dim k As Long
    Dim lbj As Integer
    Dim pNum As Integer
    Dim oprParas As Variant
    SetBytesToString sBytes, 5, beProStr
    For i = LBound(oprs) To UBound(oprs)
       oprStr = oprs(i)
       j = InStr(oprStr, "@")
       oprParas = SepedWords(Mid(oprStr, j + 1), Array(" "), pNum, "[", "]")
       lbj = LBound(oprParas)
       Select Case UCase(oprParas(lbj))
       Case "SEPLINE"
            Select Case UCase(oprParas(lbj + 1))
            Case "BYCRLF"
                 Dim crlfStr As String
                 crlfStr = FreeKH(oprParas(lbj + 2), "[", "]")
                 oprs(i) = "替换 @REPLACE [@" & crlfStr & "] ICASE0 MWORD0 [@0D0A]"
                 i = i - 1
            Case "BYLENGTH"
                 Dim chNumPerLine As Integer
                 Dim wordAsChar As Boolean
                 Dim keepOriCRLF As Boolean
                 Dim aLine As String
                 Dim LineCount As Long
                 Dim ChineseCount As Integer
                 Dim ach As String
                 Dim willSepline As Boolean
                 chNumPerLine = CInt(oprParas(lbj + 2))
                 wordAsChar = IIf(UCase(oprParas(lbj + 2)) = "WORDASCHAR1", True, False)
                 keepOriCRLF = True
                 LineCount = 0
                 ChineseCount = 0
                 aLine = ""
                 For k = 1 To Len(beProStr)
                   ach = Mid$(beProStr, k, 1)
                   willSepline = False
                   Select Case Asc(ach)
                   Case 10, 13
                      If Mid$(beProStr, k + 1, 1) = Chr$(10) Or _
                         Mid$(beProStr, k + 1, 1) = Chr$(13) Then
                         k = k + 1
                      End If
                      If keepOriCRLF Then
                         willSepline = True
                      Else
                         willSepline = False
                      End If
                   Case Is < 127
                      '汉字ASC值小于0
                      aLine = aLine & ach
                      If Asc(ach) < 0 Then ChineseCount = ChineseCount + 1
                   Case Is > 127
                      '此情形不会出现
                      If wordAsChar Then
                        If Asc(Mid$(beProStr, k + 1, 1)) > 127 Then
                          ach = TwoByteAsChar(Asc(ach), Asc(Mid$(beProStr, k + 1, 1)))
                          k = k + 1
                        End If
                      End If
                      aLine = aLine & ach
                   Case Else
                      '
                   End Select
                   If Len(aLine) >= chNumPerLine Or _
                      (Not (wordAsChar) And (Len(aLine) + ChineseCount) >= chNumPerLine) Then
                      willSepline = True
                   End If
                   If willSepline Then
                      ReDim Preserve Lines(0 To LineCount) As String
                      Lines(LineCount) = aLine
                      aLine = ""
                      ChineseCount = 0
                      LineCount = LineCount + 1
                   End If
                 Next k
                 If aLine <> "" Then
                      ReDim Preserve Lines(0 To LineCount) As String
                      Lines(LineCount) = aLine
                 End If
                 beProStr = Join(Lines, vbCrLf)
            Case "BYFLDNUM"
            End Select
       Case "REPLACE"
            Select Case UCase(oprParas(lbj + 1))
            Case "TOUPPER"
                 beProStr = UCase(beProStr)
            Case "TOLOWER"
                 beProStr = LCase(beProStr)
            Case Else
                Dim findStr As String
                Dim rplStr As String
                Dim compareMode As Integer
                Dim matchWord As Boolean
                findStr = FreeKH(oprParas(lbj + 1), "[", "]")
                If Left(findStr, 1) = "@" Then
                   findStr = HexStrAsString(Mid(findStr, 2))
                Else
                   findStr = QuetoCharProed(findStr, "\", 2)
                End If
                rplStr = FreeKH(oprParas(lbj + 4), "[", "]")
                If Left(rplStr, 1) = "@" Then
                   rplStr = HexStrAsString(Mid(rplStr, 2))
                Else
                   rplStr = QuetoCharProed(rplStr, "\", 2)
                End If
                compareMode = IIf((oprParas(lbj + 2) = "ICASE0"), vbBinaryCompare, vbTextCompare)
                matchWord = IIf(oprParas(lbj + 3) = "MWORD1", True, False)
                beProStr = ReplaceStrings(beProStr, compareMode, matchWord, findStr, rplStr)
            End Select
       Case "GETFLDS"
            Dim getFldsStr As String
            Dim sepsBefore() As String
            Dim sepAfter As String
            Dim FldsIdx As Variant
            Dim LineFlds() As String
            Dim NLineFlds() As String
            Dim tFldNum As Integer
            Dim LineFldNum As Integer
            getFldsStr = FreeKH(oprParas(lbj + 1), "[", "]")
            FldsIdx = SepedWords(getFldsStr, Array(" ", ",", ":"), tFldNum)
            sepsBefore = Split(oprParas(lbj + 2), "|")
            sepAfter = oprParas(lbj + 3)
            Lines = Split(beProStr, vbCrLf)
            Dim FldPtrs() As Integer
            Dim FldOprs() As String
            Dim FldOprNum() As Single
            Dim FldOprFmt() As String
            ReDim FldPtrs(LBound(FldsIdx) To UBound(FldsIdx)) As Integer
            ReDim FldOprs(LBound(FldsIdx) To UBound(FldsIdx)) As String
            ReDim FldOprNum(LBound(FldsIdx) To UBound(FldsIdx)) As Single
            ReDim FldOprFmt(LBound(FldsIdx) To UBound(FldsIdx)) As String
            
            Dim sFldIdx As String, iFldIdx As Integer
            Dim sFldOprNum As String, fFldOprNum As Single
            Dim HvInvalidOpr As Boolean
            
            Err.Clear
            HvInvalidOpr = False
            For j = LBound(FldsIdx) To UBound(FldsIdx)
              sFldIdx = GetSepedWord(FldsIdx(j), Array("+", "-", "*", "\", "/"), 1)
              sFldOprNum = GetSepedWord(FldsIdx(j), Array("+", "-", "*", "\", "/"), 2)
              '
              iFldIdx = CInt(sFldIdx)
              If Err Then
                    HvInvalidOpr = True
                    FldPtrs(j) = 0
                    Err.Clear
              Else
                    FldPtrs(j) = iFldIdx
              End If
              
              If InStr(FldsIdx(j), "+") > 1 Then
                    FldOprs(j) = "+"
              ElseIf InStr(FldsIdx(j), "-") > 1 Then
                    FldOprs(j) = "-"
              ElseIf InStr(FldsIdx(j), "*") > 1 Then
                    FldOprs(j) = "*"
              ElseIf InStr(FldsIdx(j), "\") > 1 Or InStr(FldsIdx(j), "/") > 1 Then
                    FldOprs(j) = "\"
              Else
                    FldOprs(j) = ""
              End If
                 
              fFldOprNum = CSng(sFldOprNum)
              If Err Then
                    HvInvalidOpr = True
                    FldOprs(j) = ""
                    FldOprNum(j) = 0#
                    Err.Clear
              Else
                    If FldOprs(j) = "" Then
                       FldOprNum(j) = 0#
                    Else
                       FldOprNum(j) = fFldOprNum
                    End If
              End If
              If FldOprs(j) = "\" And FldOprNum(j) = 0# Then
                 HvInvalidOpr = True
                 FldOprs(j) = ""
                 FldOprNum(j) = 0#
              End If
              If HvInvalidOpr = True Then
                 MsgBox "解码操作 [" & FldsIdx(j) & "] 中含有无效操作！该无效操作将被忽略！", vbCritical
                 HvInvalidOpr = False
              End If
              
              FldOprFmt(j) = "#.000|@@@@@@@@@@@@"
            Next j
            '
            Dim fldDBL As Double
            For k = LBound(Lines) To UBound(Lines)
              LineFlds = SepedWords(Lines(k), sepsBefore, LineFldNum)
              ReDim NLineFlds(LBound(FldsIdx) To UBound(FldsIdx)) As String
              For j = LBound(FldsIdx) To UBound(FldsIdx)
                NLineFlds(j) = ""
                If FldPtrs(j) <= LineFldNum Then
                   fldDBL = CDbl(LineFlds(LBound(LineFlds) + CInt(FldPtrs(j)) - 1))
                   If Err Then
                        NLineFlds(j) = LineFlds(LBound(LineFlds) + CInt(FldPtrs(j)) - 1)
                        Err.Clear
                   Else
                       Select Case FldOprs(j)
                       Case "+", "-", "*", "\", "/"
                            Select Case FldOprs(j)
                            Case "+"
                                 fldDBL = fldDBL + FldOprNum(j)
                            Case "-"
                                 fldDBL = fldDBL - FldOprNum(j)
                            Case "*"
                                 fldDBL = fldDBL * FldOprNum(j)
                            Case "/", "\"
                                 fldDBL = fldDBL / FldOprNum(j)
                            End Select
                            Dim l As Integer
                            Dim fmt As String
                            l = 1
                            fmt = GetSepedWord(FldOprFmt(j), Array("|"), l)
                            NLineFlds(j) = Format(fldDBL, fmt)
                            l = l + 1
                            While fmt <> ""
                               fmt = GetSepedWord(FldOprFmt(j), Array("|"), l)
                               If fmt <> "" Then
                                  NLineFlds(j) = Format(NLineFlds(j), fmt)
                                  l = l + 1
                               End If
                            Wend
                       Case Else
                            NLineFlds(j) = LineFlds(LBound(LineFlds) + CInt(FldsIdx(j)) - 1)
                       End Select
                   End If
                End If
              Next j
              Lines(k) = Join(NLineFlds, sepAfter)
            Next k
            beProStr = Join(Lines, vbCrLf)
       Case "AUTOLINE"
            Dim startLNo As String
            Dim stepNo As Integer
            startLNo = oprParas(lbj + 1)
            stepNo = CInt(oprParas(lbj + 2))
            Lines = Split(beProStr, vbCrLf)
            For k = LBound(Lines) To UBound(Lines)
              Lines(k) = startLNo & Lines(k)
              startLNo = GetAddedString(startLNo, stepNo)
            Next k
            beProStr = Join(Lines, vbCrLf)
       End Select
    Next i
    proedStr = beProStr
    SetStringToBytes beProStr, proedBytes
  End If
End Sub


Public Function ReplaceStrings(ByVal resString As String, ByVal schMode As Integer, ByVal matchWholeWord As Boolean, ParamArray varReplacements() As Variant) As String
'schMode=vbBinaryCompare or vbTextCompare
'当不是匹配完全词时(matchWholeWord=false)，用系统REPLACE函数更快
    Dim i As Integer
    ' For each macro/value pair passed in...
    For i = LBound(varReplacements) To UBound(varReplacements) Step 2
        Dim schStr As String
        Dim rplStr As String
        
        schStr = varReplacements(i)
        On Error GoTo MismatchedPairs
        rplStr = varReplacements(i + 1)
        On Error GoTo 0
        ' Replace all occurrences of schStr with rplStr
        If schStr = rplStr Or (schMode = vbTextCompare And UCase(schStr) = UCase(rplStr)) Then GoTo NextSchRpl
        If matchWholeWord = False Then
           resString = Replace(resString, schStr, rplStr, , , schMode)
           GoTo NextSchRpl
        End If
        Dim intPos As Long
        Dim StPos As Long
        Dim lch As String
        Dim rch As String
        StPos = 1
        Do
            intPos = InStr(StPos, resString, schStr, schMode)
            If intPos > 0 Then
                If matchWholeWord Then