mstrfun.bas

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

Attribute VB_Name = "mStrFun"
Option Explicit

Public Const AlignmentLeft As Integer = 0
Public Const AlignmentMid As Integer = 1
Public Const AlignmentRight As Integer = 2



Public Const DECODE_ORIGINMODE = 0
Public Const DECODE_TOTEXTMODE = 1

'用于DeCodeSaveMode的常量
Public Const DECODE_SAVEASBINARY = 0
Public Const DECODE_SAVEASDECASCII = 1
Public Const DECODE_SAVEASHEXASCII = 2

'Global Const AlignmentLeft As Integer = 0
'Global Const AlignmentMid As Integer = 1
'Global Const AlignmentRight As Integer = 2


Public Function StrSize(ByVal astr) As Long
'实质与LenB()函数不一样，LenB()可含双字节字符中的第2个0字节
Dim i As Long
StrSize = 0
If astr = "" Then Exit Function
For i = 1 To Len(astr)
  StrSize = StrSize + IIf(Len(Hex(Asc(Mid(astr, i, 1)))) > 2, 2, 1)
Next i
End Function


Public Function IsChinese(ByVal ch As String) As Boolean
Dim acode As Integer
If ch = "" Then
  IsChinese = False
Else
  acode = Asc(ch)
  IsChinese = (acode > 128) Or (acode < 0)
End If
End Function

Public Function IsAlpha(ByVal ch As String) As Boolean
Dim acode As Integer
If ch = "" Then
  IsAlpha = False
Else
  acode = Asc(ch)
  IsAlpha = ((acode > 64 And acode < 91) Or (acode > 96 And acode < 123))
End If
End Function

Public Function IsNumber(ByVal ch As String) As Boolean
Dim acode As Integer
If ch = "" Then
  IsNumber = False
Else
  acode = Asc(ch)
  IsNumber = (acode > &H2F And acode < &H3A)
End If
End Function

Public Function IsHexChar(ByVal ch As String) As Boolean
Dim acode As Integer
If ch = "" Then
  IsHexChar = False
  Exit Function
End If
acode = Asc(ch)
IsHexChar = ((acode >= Asc("0") And acode <= Asc("9")) Or _
             (acode >= Asc("a") And acode <= Asc("f")) Or _
             (acode >= Asc("A") And acode <= Asc("F")))
End Function



Public Function IsRemComma(ByVal ch As String) As Boolean
IsRemComma = IsIn(ch, Array(" ", ",", ":", ";", "/", "\", "'", ".", "<", ">", "?", Chr$(9), _
                        "[", "]", "{", "}", "+", "_", "=", "*", "&", "^", "%", "$", "#", _
                        "(", ")", "|", "@", "!", "~", "`"))
End Function

Public Function CutRem(ByVal srcStr As String, Optional ByVal remString As String = ";", _
                       Optional ByVal leftKH As String = "", _
                       Optional ByVal RightKH As String = "") As String
  Dim i As Integer
  Dim inFlag As Integer
  Dim ch As String
  Dim srcString As String
  Dim remLen As Integer
  Dim remIn As Integer
  Dim leftKhIn As Integer
  Dim RightKhIn As Integer
  Dim oRightKhIn As Integer
  Dim StartPos As Integer
  Dim remL As String
  Dim remR As String
  
  If leftKH = "" Or RightKH = "" Then
    leftKH = "CANOT_BE_THIS_VB_CUTREM_FUNCTION_STRING_BY_ZHUYIHU_2000.3.30.13.17"
    RightKH = leftKH
  End If
  StartPos = 1
   '
srcString = UCase$(srcStr)
remString = UCase$(remString)

Do
  remIn = InStr(StartPos, srcString, remString, vbBinaryCompare)
  If remIn < StartPos Then
    CutRem = srcStr
    Exit Function
  End If
  leftKhIn = InStr(StartPos, srcString, leftKH, vbBinaryCompare)
  If leftKhIn < StartPos Then
    If IsRemComma(remString) Then
       CutRem = Left$(srcStr, remIn - 1)
       Exit Function
    End If
    remL = Mid$(srcString, remIn - 1, 1)
    remR = Mid$(srcString, remIn + Len(remString), 1)
    If (IsRemComma(remL) Or remL = "") And (IsRemComma(remR) Or remR = "") Then
       CutRem = Left$(srcStr, remIn - 1)
       Exit Function
    Else
       StartPos = remIn + 1
    End If
  Else
    RightKhIn = leftKhIn
    While RightKhIn <= leftKhIn
      oRightKhIn = RightKhIn
      RightKhIn = InStr(oRightKhIn + 1, srcString, RightKH, vbBinaryCompare)
      If RightKhIn < oRightKhIn + 1 Then RightKhIn = Len(srcString) + 1
    Wend
    If leftKhIn > remIn Then
      If IsRemComma(remString) Then
         CutRem = Left$(srcStr, remIn - 1)
         Exit Function
      End If
      remL = Mid$(srcStr, remIn - 1, 1)
      remR = Mid$(srcStr, remIn + Len(remString), 1)
      If (IsRemComma(remL) Or remL = "") And (IsRemComma(remR) Or remR = "") Then
         CutRem = Left$(srcStr, remIn - 1)
         Exit Function
      Else
         StartPos = RightKhIn
      End If
    Else
      If remIn < RightKhIn Then
         StartPos = RightKhIn + Len(RightKH)
      Else
         CutRem = Left$(srcStr, remIn - 1)
         Exit Function
      End If
    End If
  End If
Loop
End Function


Public Function FreeKH(ByVal srcStr As String, _
                       Optional ByVal leftKH As String = "", _
                       Optional ByVal RightKH As String = "") As String
Dim sResult As String
Dim mtoSp As Boolean
Dim ch As String
Dim sstr As String

sstr = srcStr
       If sstr = "" Then
         FreeKH = ""
         Exit Function
       End If
       sResult = ""
       mtoSp = False
       While Len(sstr) > 0
            ch = Left$(sstr, 1)
            sstr = Mid$(sstr, 2)
            If mtoSp = False Then
               If UCase$(ch) = UCase$(leftKH) Then
                  ch = ""
                  mtoSp = True
               End If
            Else
               If UCase$(ch) = UCase$(RightKH) Then
                  ch = ""
                  mtoSp = False
               End If
            End If
            sResult = sResult & ch
       Wend
       FreeKH = sResult
End Function

Public Function TrimTab(ByVal srcStr As String) As String
Dim sstr As String
sstr = srcStr
While Left$(sstr, 1) = Chr$(9)
  sstr = Mid$(sstr, 2)
Wend
While Right$(sstr, 1) = Chr$(9)
  sstr = Left$(sstr, Len(sstr) - 1)
Wend
TrimTab = sstr
End Function

Public Function TabToSpace(ByVal sstr As String, Optional ByVal SPsPerTab As Integer = 1) As String
TabToSpace = Replace(sstr, Chr$(9), String(SPsPerTab, " "))
End Function

Function TrimMid(ByVal srcStr As String) As String
'压缩中间的空格，至少保留一个空格。但若[]中有空格则也被压缩
Dim in1 As Integer
Dim sstr As String
sstr = Replace(srcStr, Chr$(9), " ")
in1 = InStr(1, sstr, "  ", 0)
While in1 > 0
  sstr = Left(sstr, in1 - 1) & Right(sstr, Len(sstr) - in1)
  in1 = InStr(1, sstr, "  ", 0)
Wend
TrimMid = sstr
End Function

'---------------------------------------------------------------------------
Function GetKeyInStr(ByVal kstr As String, ByVal GetNo As Integer) As String
Dim in1 As Integer
Dim GetStr As String
Dim sepStr As String
If Left(kstr, 2) = "%%" Then
  in1 = InStr(3, kstr, "%%", 0)
  If in1 > 0 Then
    sepStr = Mid(kstr, 3, in1 - 3)
    kstr = Right(kstr, Len(kstr) - in1 - 1)
  Else
    sepStr = " - "
  End If
  If sepStr = "" Then
    sepStr = " - "
  End If
Else
  sepStr = " - "
End If
If sepStr = " " Then kstr = TrimMid(kstr)
While GetNo > 0 And Len(kstr) > 0
  in1 = InStr(1, kstr, sepStr, 0)
  If in1 > 0 Then
    GetStr = Left(kstr, in1 - 1)
    kstr = Mid(kstr, in1 + Len(sepStr))
    If kstr = "" And GetNo > 1 Then GetStr = ""
  Else
    GetStr = kstr
    kstr = ""
    If GetNo > 1 Then
      GetStr = ""
    End If
  End If
  GetNo = GetNo - 1
Wend
GetKeyInStr = GetStr
End Function

Public Function ArrayAppend(ByVal srcArray As Variant, ByVal addArrayOrAtom As Variant) As Variant
Dim SA As Variant
Dim aa As Variant
Dim aAtom As Variant
Dim ls As Integer
Dim la As Integer
Dim i As Integer
SA = srcArray
If TypeName(addArrayOrAtom) = "Variant()" Then
   aa = addArrayOrAtom
Else
   aa = Array(addArrayOrAtom)
End If
If IsNull(SA) Or IsEmpty(SA) Then
   ArrayAppend = aa
   Exit Function
Else
   ls = UBound(SA) - LBound(SA) + 1
   la = UBound(aa) - LBound(aa) + 1
   ReDim Preserve SA(LBound(SA) To (ls + la + LBound(SA) - 1))
End If
i = LBound(SA) + ls
For Each aAtom In aa
  SA(i) = aAtom
  i = i + 1
Next aAtom
ArrayAppend = SA
End Function


Public Function ArrayDelete(ByVal srcArray As Variant, ByVal delArrayOrAtom As Variant, Optional ByVal blDeleteAllFounded As Boolean = True) As Variant
'删除数组原子方法是：新建结果空数组，对源数组原子一一搜索，查是否在要删数组中，如不在，则结果数组扩增
'所以，blDeleteAllFounded应理解为：对要删的数组中各原子，是否全删；而不是对源数组中某一原子出现多次时是否全删
Dim aa As Variant
Dim aAtom As Variant
Dim dA As Variant
Dim bFoundOne As Boolean
Dim blKeepIt As Boolean
'
If IsNull(srcArray) Or IsEmpty(srcArray) Then
   ArrayDelete = srcArray
   Exit Function
Else
   If TypeName(delArrayOrAtom) = "Variant()" Then
      aa = delArrayOrAtom
   Else
      aa = Array(delArrayOrAtom)
   End If
   dA = Array()
   bFoundOne = False
   For Each aAtom In srcArray
      If IsIn(aAtom, aa) Then
         If blDeleteAllFounded Then
            blKeepIt = False
         Else
            If bFoundOne Then
               blKeepIt = True
            Else
               blKeepIt = False
            End If
         End If
         bFoundOne = True
      Else
         blKeepIt = True
      End If
      '
      If blKeepIt Then
         ReDim Preserve dA(LBound(dA) To (UBound(dA) + 1))
         dA(UBound(dA)) = aAtom
      End If
   Next aAtom
   ArrayDelete = dA
End If
End Function


Public Function ArrayAtomReplace(ByRef srcArray As Variant, ByVal SchAtom As Variant, ByVal RplAs As Variant, ByVal RplAllFounded As Boolean) As Boolean
Dim i As Integer
For i = LBound(srcArray) To UBound(srcArray)
  If srcArray(i) = SchAtom Then
     srcArray(i) = RplAs
     If Not RplAllFounded Then Exit For
  End If
Next i
End Function

Public Function ArraySort(ByVal srcArray As Variant, ByVal OrderLowToHigh As Boolean) As Variant
Dim mArray As Variant
If UBound(srcArray) - LBound(srcArray) + 1 = 1 Then
  ArraySort = srcArray
  Exit Function
End If
Dim aAtom As Variant
Dim i As Long
Dim j As Long
mArray = srcArray
For i = LBound(mArray) To UBound(mArray) - 1
  For j = (i + 1) To UBound(mArray)
    If ((mArray(i) > mArray(j)) And OrderLowToHigh) Or _
       ((mArray(i) < mArray(j)) And Not (OrderLowToHigh)) Then
       aAtom = mArray(i)
       mArray(i) = mArray(j)
       mArray(j) = aAtom
    End If
  Next j
Next i
ArraySort = mArray
End Function


Public Function Minium(ByVal mArray As Variant) As Variant
Dim SA As Variant
SA = ArraySort(mArray, True)
Minium = SA(LBound(SA))
End Function

Public Function Maxium(ByVal mArray As Variant) As Variant
Dim SA As Variant
SA = ArraySort(mArray, True)
Maxium = SA(UBound(SA))
End Function

Public Function IsIn(ByVal aAtom As Variant, ByVal srcArray As Variant) As Boolean
'检查原子是否在数组中
'原子类型可以是任意简单类型,如是字符串，不比较大小写，而进行完全匹配