mstrfun.bas

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

Dim aa As Variant
IsIn = False
If IsEmpty(srcArray) Or IsNull(srcArray) Then
   Exit Function
Else
   If UBound(srcArray) - LBound(srcArray) + 1 = 0 Then Exit Function
End If
For Each aa In srcArray
  If aa = aAtom Then
    IsIn = True
    Exit For
  End If
Next aa
End Function

Public Function InStrOr(ByVal srcStr As String, ByVal subStrs As Variant, Optional ByVal StPos As Integer = 1, Optional ByVal cmpMode As Integer = vbBinaryCompare) As Boolean
  Dim i As Integer
  InStrOr = False
  For i = LBound(subStrs) To UBound(subStrs)
    If InStr(StPos, srcStr, subStrs(i), cmpMode) > 0 Then
       InStrOr = True
       Exit Function
    End If
  Next i
End Function

Public Function InStrAnd(ByVal srcStr As String, ByVal subStrs As Variant, Optional ByVal StPos As Integer = 1, Optional ByVal cmpMode As Integer = vbBinaryCompare) As Boolean
  Dim i As Integer
  InStrAnd = True
  For i = LBound(subStrs) To UBound(subStrs)
    If InStr(StPos, srcStr, subStrs(i), cmpMode) <= 0 Then
       InStrAnd = False
       Exit Function
    End If
  Next i
End Function


Public Function IsInOr(ByVal Atoms As Variant, ByVal srcArray As Variant) As Boolean
  Dim i As Integer
  IsInOr = False
  For i = LBound(Atoms) To UBound(Atoms)
    If IsIn(Atoms(i), srcArray) Then
       IsInOr = True
       Exit Function
    End If
  Next i
End Function

Public Function IsInAnd(ByVal Atoms As Variant, ByVal srcArray As Variant) As Boolean
  Dim i As Integer
  Dim AtomIsIn As Boolean
  IsInAnd = True
  For i = LBound(Atoms) To UBound(Atoms)
    If IsIn(Atoms(i), srcArray) = False Then
       IsInAnd = False
       Exit Function
    End If
  Next i
End Function

Public Function GetSepedWord(ByVal srcStr As String, ByVal sepStrs As Variant, ByVal GetNo As Integer, Optional ByRef rslSuccess As Boolean, Optional ByVal leftKH As String = "", Optional ByVal RightKH As String = "") As String
Dim ss As Variant
Dim wordNum As Integer
ss = SepedWords(srcStr, sepStrs, wordNum, leftKH, RightKH)
'ArrayToStr ss, vbCrLf, True
If wordNum = 0 Then
   GetSepedWord = ""
   rslSuccess = False
Else
   If GetNo > (UBound(ss) - LBound(ss) + 1) Then
      GetSepedWord = ""
      rslSuccess = False
   Else
      GetSepedWord = ss(LBound(ss) + GetNo - 1)
      rslSuccess = True
   End If
End If
End Function

Public Function SepedWords(ByVal srcStr As String, ByVal sepStrs As Variant, Optional ByRef wordNum As Integer, _
                           Optional ByVal leftKH As String = "", Optional RightKH As String = "", Optional ByVal bUcaseWord As Boolean = False) As Variant
                           
'调用前用于接受返回值的变量申明如:    Dim oprParas As Variant
                           
Dim sWords() As String
Dim aWord As String
Dim wordCount As Integer
Dim i As Long
Dim inFlag As Integer
Dim ch As String
Dim sstr As String
Dim HaveSpace As Boolean
Dim HaveTab As Boolean

If srcStr = "" Then
  SepedWords = Null
  wordNum = 0
  Exit Function
End If
 
 Dim tLen As Integer
 If bUcaseWord Then
    sstr = UCase(srcStr)
 Else
    sstr = srcStr
 End If
HaveSpace = IsIn(" ", sepStrs)
HaveTab = IsIn(Chr$(9), sepStrs)
If HaveSpace And HaveTab Then
   Do
     tLen = Len(sstr)
     sstr = Trim$(sstr)
     sstr = TrimTab(sstr)
   Loop While tLen <> Len(sstr)
ElseIf HaveSpace Then
   sstr = Trim$(srcStr)
ElseIf HaveTab Then
   sstr = TrimTab(srcStr)
End If
'
If leftKH = "" Or RightKH = "" Then
    leftKH = "CANOT_BE_THIS_VB_CUTREM_FUNCTION_STRING_BY_ZHUYIHU_2000.3.30.13.17"
    RightKH = leftKH
End If

 wordCount = 0
 
 i = 1
 inFlag = 0
 While sstr <> ""
 
 'MsgBox "in=" & sStr
    ch = Mid$(sstr, i, 1)
    If ch = leftKH And inFlag <= 0 Then
      inFlag = 1 + inFlag
      i = i + 1
      GoTo FUN_SEPEDSTR
    End If
    If ch = RightKH And inFlag > 0 Then
      inFlag = inFlag - 1
      i = i + 1
      GoTo FUN_SEPEDSTR
    End If
    '
    If inFlag <= 0 Then
      If IsIn(ch, sepStrs) Then
        If (ch = " " And IsIn(Mid$(sstr, 1 + i, 1), sepStrs)) Or _
           (ch = Chr$(9) And IsIn(Mid$(sstr, 1 + i, 1), sepStrs)) Then
          i = i + 1
        Else
          aWord = Mid$(sstr, 1, i - 1)
          If HaveSpace Then aWord = Trim(aWord)
          If HaveTab Then aWord = TrimTab(aWord)
          wordCount = wordCount + 1
          ReDim Preserve sWords(1 To wordCount)
          sWords(wordCount) = FreeKH(aWord, leftKH, RightKH)
          sstr = Mid$(sstr, 1 + i)
          If HaveSpace Then sstr = Trim$(sstr)
          If HaveTab Then sstr = Trim$(sstr)
          i = 1
        End If
      Else
        i = i + 1
        If i > Len(sstr) Then
          aWord = Mid$(sstr, 1, i - 1)
          wordCount = wordCount + 1
          ReDim Preserve sWords(1 To wordCount)
          sWords(wordCount) = FreeKH(aWord, leftKH, RightKH)
          sstr = ""
        End If
      End If
    Else
      i = i + 1
    End If
FUN_SEPEDSTR:
 Wend
 '
 If wordCount = 0 Then
   SepedWords = Null
 Else
   SepedWords = sWords
 End If
 wordNum = wordCount
End Function


Sub SetStringToBytes(ByVal sstr As String, ByRef bytes() As Byte)
Dim ch As String
Dim bPtr As Long
Dim tLen As Long
Dim i As Long
tLen = Len(sstr)
If tLen = 0 Then
   Dim ttBytes() As Byte
   bytes = ttBytes
   Exit Sub
End If
'
bPtr = 0
ReDim Preserve bytes(0 To tLen - 1) As Byte
For i = 1 To Len(sstr)
  ch = Mid(sstr, i, 1)
  'If Len(Hex(Asc(ch))) < 3 Then
  '   bytes(bPtr) = Asc(ch)
  '   bPtr = bPtr + 1
  'Else
  '   ReDim Preserve bytes(0 To tLen) As Byte
  '   tLen = tLen + 1
  '   bytes(bPtr) = CInt("&H0" & Left(Hex(Asc(ch)), Len(Hex(Asc(ch))) - 2))
  '   bytes(bPtr + 1) = CInt("&H0" & Right(Hex(Asc(ch)), 2))
  '   bPtr = bPtr + 2
  'End If
  If Asc(ch) >= 0 Then
     bytes(bPtr) = Asc(ch)
     bPtr = bPtr + 1
  Else
     'MsgBox "chinese!!!"
     ReDim Preserve bytes(0 To tLen) As Byte
     tLen = tLen + 1
     bytes(bPtr + 1) = (Asc(ch) + 65536) Mod 256
     bytes(bPtr) = (Asc(ch) + 65536 - bytes(bPtr + 1)) / 256
     bPtr = bPtr + 2
  End If
Next i
End Sub


Public Sub SetBytesToString(bytes() As Byte, toString As Long, ByRef rStr As String)
'If MsgBox("use new?", vbYesNo) = vbYes Then
  SetBytesToString2 bytes, toString, rStr
  Exit Sub
'End If
Dim j As Long
Dim s As String
  rStr = ""
  'strCount = LBound(bytes)
  Dim st As Date
  st = Now
        Select Case (toString And &H3)
        Case 0   '原样
            For j = LBound(bytes) To UBound(bytes)
              rStr = rStr & Chr(bytes(j))
            Next j
        Case 1  '准文本，不可显示的用.代替
            For j = LBound(bytes) To UBound(bytes)
            If (bytes(j) >= &H1E And bytes(j) < 126) Or bytes(j) = 13 Or bytes(j) = 10 Then
              rStr = rStr & Chr(bytes(j))
            Else
              If bytes(j) > 127 And (toString And &H4) > 0 Then
                rStr = rStr & Chr(CLng(bytes(j)) * 256 + bytes(j + 1) - &H10000)
                j = j + 1
              Else
                rStr = rStr & "."
              End If
            End If
            Next j
        Case 2 '十进制字节值
            For j = LBound(bytes) To UBound(bytes)
            'rStr = rStr & Format(CStr(Format(bytes(j), "###")), "@@@")
            rStr = rStr & Format(bytes(j), "0##")
            If (j - LBound(bytes) + 1) Mod 16 = 0 Then
              rStr = rStr & vbCrLf
            Else
              rStr = rStr & " "
            End If
            Next j
        Case 3 '十六进制字节值  7   6   5   4   3   2   1   0(bit)
               '                                0    0   0   0=原样显示
               '                                0   0   0   1=准文本
               '                                0   1   0   1=准文本（汉字）
               '                                0   0   1   0=十进制
               '                                0   0   1   1=十六进制(不用0补足两位十六进制数)
               '                                1   0   1   1=十六进制(用0补足两位十六进制数)
               '                *   *   *   *   字节之间加空格数
               '               高位字节值为换行字节数
            Dim sepLineBytes As Integer
            Dim SepByteSPs As Integer
            sepLineBytes = (toString And &HFF00) / 256
            For j = LBound(bytes) To UBound(bytes)
               s = Hex(bytes(j))
               If (toString And &H8) > 0 Then
                   If Len(s) < 2 Then s = "0" & s
               End If
               rStr = rStr & s
               If sepLineBytes > 0 Then
                 If (j - LBound(bytes) + 1) Mod sepLineBytes = 0 Then
                   rStr = rStr & vbCrLf
                 Else
                   SepByteSPs = (toString And &HF0) / 16
                   If SepByteSPs > 0 Then
                     rStr = rStr & String(SepByteSPs, " ")
                   End If
                 End If
               Else
                 SepByteSPs = (toString And &HF0) / 16
                 If SepByteSPs > 0 Then
                     rStr = rStr & String(SepByteSPs, " ")
                 End If
               End If
            Next j
        Case Else
            '
        End Select
'MsgBox "in old, bytestostring," & DateDiff("s", Now, st) & ",len=" & (UBound(bytes) - LBound(bytes) + 1)
End Sub


Public Sub SetBytesToString2(bytes() As Byte, toString As Long, ByRef rStr As String)
Dim j As Long
Dim s As String
Dim tStr() As String
Dim strcount As Long
  rStr = ""
  strcount = LBound(bytes)
  ReDim tStr(LBound(bytes) To UBound(bytes)) As String
  Dim st As Date
  st = Now
        Select Case (toString And &H3)
        Case 0   '原样
            For j = LBound(bytes) To UBound(bytes)
              tStr(j) = Chr(bytes(j))
            Next j
        Case 1  '准文本，不可显示的用.代替
            For j = LBound(bytes) To UBound(bytes)
            If (bytes(j) >= &H1E And bytes(j) < 126) Or bytes(j) = 13 Or bytes(j) = 10 Then
              tStr(strcount) = Chr(bytes(j))
            Else
              If bytes(j) > 127 And (toString And &H4) > 0 Then
                tStr(strcount) = TwoByteAsChar(bytes(j), bytes(j + 1))
                j = j + 1
              Else
                tStr(strcount) = "."
              End If
            End If
            strcount = strcount + 1
            Next j
            ReDim Preserve tStr(LBound(bytes) To strcount - 1) As String
        Case 2 '十进制字节值
            For j = LBound(bytes) To UBound(bytes)
            'rStr = rStr & Format(CStr(Format(bytes(j), "###")), "@@@")
            tStr(j) = Format(bytes(j), "0##")
            If (j - LBound(bytes) + 1) Mod 16 = 0 Then
              tStr(j) = tStr(j) & vbCrLf
            Else
              tStr(j) = tStr(j) & " "
            End If
            Next j
        Case 3 '十六进制字节值  7   6   5   4   3   2   1   0(bit)
               '                                0    0   0   0=原样显示
               '                                0   0   0   1=准文本
               '                                0   1   0   1=准文本（汉字）
               '                                0   0   1   0=十进制
               '                                0   0   1   1=十六进制(不用0补足两位十六进制数)
               '                                1   0   1   1=十六进制(用0补足两位十六进制数)
               '                *   *   *   *   字节之间加空格数
               '               高位字节值为换行字节数
            Dim sepLineBytes As Integer
            Dim SepByteSPs As Integer
            sepLineBytes = (toString And &HFF00) / 256
            For j = LBound(bytes) To UBound(bytes)
               s = Hex(bytes(j))
               If (toString And &H8) > 0 Then
                   If Len(s) < 2 Then s = "0" & s
               End If
               rStr = s
               If sepLineBytes > 0 Then
                 If (j - LBound(bytes) + 1) Mod sepLineBytes = 0 Then
                   rStr = rStr & vbCrLf
                 Else
                   SepByteSPs = (toString And &HF0) / 16
                   If SepByteSPs > 0 Then
                     rStr = rStr & String(SepByteSPs, " ")
                   End If
                 End If
               Else
                 SepByteSPs = (toString And &HF0) / 16
                 If SepByteSPs > 0 Then
                     rStr = rStr & String(SepByteSPs, " ")
                 End If
               End If
               tStr(j) = rStr
            Next j
        Case Else
            '
        End Select
        rStr = Join(tStr, "")