mstrfun.bas

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

                  If intPos = 1 Then
                     lch = ""
                  Else
                     lch = Mid$(resString, intPos - 1, 1)
                  End If
                  rch = Mid$(resString, intPos + Len(schStr), 1)
                  If (lch = "" Or IsRemComma(lch)) And (rch = "" Or IsRemComma(rch)) Then
                     resString = Left$(resString, intPos - 1) & rplStr & Right$(resString, Len(resString) - Len(schStr) - intPos + 1)
                     StPos = intPos + Len(rplStr)
                  Else
                     StPos = intPos + 1
                  End If
                Else
                  resString = Left$(resString, intPos - 1) & rplStr & Right$(resString, Len(resString) - Len(schStr) - intPos + 1)
                  StPos = intPos + Len(rplStr)
                End If
            Else
                StPos = intPos + 1
            End If
        Loop Until intPos = 0
NextSchRpl:
    Next i
    ReplaceStrings = resString
    Exit Function
MismatchedPairs:
    Resume Next
End Function

Public Function HexStrAsString(ByVal hexStr As String) As String
  Dim hStr As String
   If IsValidHexString(hexStr, hStr) Then
     Dim s As String
     Dim i As Long
     s = ""
     For i = 1 To Len(hStr) Step 2
        s = s & Chr(CInt("&H" & Mid$(hStr, i, 2)))
     Next i
     HexStrAsString = s
   Else
     HexStrAsString = ""
   End If
End Function


Public Function GetAddedString(ByVal srcStr As String, ByVal iStep As Integer, Optional ByRef strDigLeft As String, Optional strDigRight As String, Optional strDigSelf As String) As String
'串中数字增量返回
Dim i As Long
Dim dPos As Integer
Dim d2Pos As Integer
Dim ch As String
Dim digPoses As Variant
Dim alStr As String
Dim amStr As String
Dim arStr As String
On Error Resume Next
Err.Clear
digPoses = Array()
   For i = 1 To 12
     dPos = InStr(srcStr, Choose(i, "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "+", "-"))
     If dPos > 0 Then
          digPoses = ArrayAppend(digPoses, Array(dPos))
     End If
   Next i
   
   If UBound(digPoses) - LBound(digPoses) + 1 <= 0 Then
      GetAddedString = srcStr & CStr(iStep)
      alStr = srcStr
      arStr = ""
      amStr = ""
   Else
      dPos = Minium(digPoses)
      d2Pos = dPos
      While IsIn(Mid$(srcStr, d2Pos + 1, 1), Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "0"))
         d2Pos = d2Pos + 1
      Wend
      If dPos = 1 Then
        alStr = ""
        amStr = Mid(srcStr, dPos, d2Pos - dPos + 1)
        arStr = Mid(srcStr, d2Pos + 1)
      Else
        alStr = Left(srcStr, dPos - 1)
        amStr = Mid(srcStr, dPos, d2Pos - dPos + 1)
        arStr = Mid(srcStr, d2Pos + 1)
      End If
      i = CLng(amStr)
      If Err Then
         amStr = "0"
         Err.Clear
      End If
      GetAddedString = alStr & CStr(CLng(amStr) + iStep) & arStr
   End If
   strDigLeft = alStr
   strDigRight = arStr
   strDigSelf = amStr
End Function

Public Function QuetoCharProed(ByVal srcStr As String, ByVal QuetoChar As String, ByVal ProMode As Integer) As String
'将字符串中的引导符去除，根据要求处理引导符后的内容
'如果引导符为字母，则用vbTextCompare方式找引导符
'Promode=0,  仅去除引导符
'Promode=1,  去除引导符，将其后两字符按十六进制处理成一个字符
'Promode=2,  =0+1,去除引导符，并将其后两字符按十六进制处理成一个字符
'...
'Promode=10,  加引导符处理(扩充)
Dim StPos As Long
Dim intPos As Long
Dim hStr As String
StPos = 1
Do
  intPos = InStr(StPos, srcStr, QuetoChar, vbTextCompare)
  If intPos > 0 Then
     Select Case ProMode
     Case 0
          If UCase(Mid(srcStr, intPos + Len(QuetoChar), Len(QuetoChar))) = UCase(QuetoChar) Then
             StPos = intPos + Len(QuetoChar)
             '已去除引导符
          Else
             StPos = intPos
          End If
          srcStr = Left(srcStr, intPos - 1) & Right(srcStr, Len(srcStr) - intPos + 1 - Len(QuetoChar))
     Case 1
          If IsValidHexString(Mid(srcStr, intPos + Len(QuetoChar), 1)) Then
             If IsValidHexString(Mid(srcStr, intPos + Len(QuetoChar) + 1, 1)) Then
                IsValidHexString Mid(srcStr, intPos + Len(QuetoChar), 2), hStr
                srcStr = Left(srcStr, intPos - 1) & Chr(CInt("&H0" & hStr)) & Right(srcStr, Len(srcStr) - Len(QuetoChar) - intPos + 1 - 2)
                StPos = intPos + 1
             Else
                IsValidHexString "0" & Mid(srcStr, intPos + Len(QuetoChar), 1), hStr
                srcStr = Left(srcStr, intPos - 1) & Chr(CInt("&H0" & hStr)) & Right(srcStr, Len(srcStr) - Len(QuetoChar) - intPos + 1 - 1)
                StPos = intPos + 1
             End If
          Else
             srcStr = Left(srcStr, intPos - 1) & Right(srcStr, Len(srcStr) - Len(QuetoChar) - intPos + 1)
             StPos = intPos
          End If
     Case 2  '去引导符并转十六进制字符
          If UCase(Mid(srcStr, intPos + Len(QuetoChar), Len(QuetoChar))) = UCase(QuetoChar) Then
             srcStr = Left(srcStr, intPos - 1) & Right(srcStr, Len(srcStr) - intPos + 1 - Len(QuetoChar))
             StPos = intPos + Len(QuetoChar)
          Else
             If IsValidHexString(Mid(srcStr, intPos + Len(QuetoChar), 1)) Then
                If IsValidHexString(Mid(srcStr, intPos + Len(QuetoChar) + 1, 1)) Then
                   IsValidHexString Mid(srcStr, intPos + Len(QuetoChar), 2), hStr
                   srcStr = Left(srcStr, intPos - 1) & Chr(CInt("&H0" & hStr)) & Right(srcStr, Len(srcStr) - Len(QuetoChar) - intPos + 1 - 2)
                   StPos = intPos + 1
                Else
                   IsValidHexString "0" & Mid(srcStr, intPos + Len(QuetoChar), 1), hStr
                   srcStr = Left(srcStr, intPos - 1) & Chr(CInt("&H0" & hStr)) & Right(srcStr, Len(srcStr) - Len(QuetoChar) - intPos + 1 - 1)
                   StPos = intPos + 1
                End If
             Else
                srcStr = Left(srcStr, intPos - 1) & Right(srcStr, Len(srcStr) - Len(QuetoChar) - intPos + 1)
                StPos = intPos
             End If
          End If
     Case 10
          srcStr = Left(srcStr, intPos - 1) & QuetoChar & QuetoChar & Right(srcStr, Len(srcStr) - Len(QuetoChar) - intPos + 1)
          StPos = intPos + Len(QuetoChar) * 2
     Case Else
     End Select
  End If
Loop Until intPos = 0
QuetoCharProed = srcStr
End Function


Function ToHourUnitTime(ByVal SD As Date) As String
        If SD < 1# Then
           ToHourUnitTime = Format(SD, "hh:mm:ss")
        Else
           ToHourUnitTime = Format(Int(SD * 24#), "00") & ":" & Format(Minute(SD), "00") & ":" & Format(Second(SD), "00")
        End If
End Function

Public Function StrExtendToLength(srcVal, ByVal tolen As Integer, ByVal AddCh As String, ByVal AddAlignment As Integer, LenIsTheStrSize As Boolean, Optional fmt As String = "") As String
'srcVal 可以是任何类型
Dim AddPos As Integer
Dim sstr As String
On Error Resume Next
Err.Clear
If UCase(TypeName(srcVal)) <> "STRING" Or fmt <> "" Then
   sstr = Format(srcVal, fmt)
Else
   sstr = srcVal
End If
If Err Then sstr = ""
   Select Case AddAlignment
   Case AlignmentLeft
        AddPos = AddAlignment
   Case AlignmentMid
        AddPos = AlignmentLeft
   Case AlignmentRight
        AddPos = AddAlignment
   Case Else
        AddPos = AlignmentLeft
   End Select
   
If LenIsTheStrSize Then
   While StrSize(sstr) < tolen
      Select Case AddPos
      Case AlignmentRight
           sstr = sstr & AddCh
           If AddAlignment = AlignmentMid Then
              AddPos = AlignmentLeft
           End If
      Case AlignmentLeft
           sstr = AddCh & sstr
           If AddAlignment = AlignmentMid Then
              AddPos = AlignmentRight
           End If
      End Select
   Wend
   StrExtendToLength = sstr
Else
   While Len(sstr) < tolen
      Select Case AddPos
      Case AlignmentRight
           sstr = sstr & AddCh
           If AddAlignment = AlignmentMid Then
              AddPos = AlignmentLeft
           End If
      Case AlignmentLeft
           sstr = AddCh & sstr
           If AddAlignment = AlignmentMid Then
              AddPos = AlignmentRight
           End If
      End Select
   Wend
   StrExtendToLength = sstr
End If
End Function


Public Function InWord(ByVal srcStr As String, ByVal sepStrs As Variant, ByVal sWord As String, Optional ByVal StartPos As Integer = 1, _
                           Optional ByVal leftKH As String = "", Optional RightKH As String = "") As Integer
'查srcStr中是否存在词sWord
Dim sWords() As String
Dim wnum As Integer
Dim i As Integer
sWords = SepedWords(srcStr, sepStrs, wnum, leftKH, RightKH)
If wnum = 0 Then
  InWord = 0
Else
  If StartPos < 1 Then StartPos = 1
  If StartPos > wnum Then
    InWord = 0
  Else
    For i = LBound(sWords) + StartPos - 1 To UBound(sWords)
      If UCase$(sWords(i)) = UCase$(sWord) Then
        InWord = i - LBound(sWords) + 1
        Exit For
      End If
    Next i
  End If
End If
End Function

Public Function GetEnvString(ByVal envTopic As String) As String
Dim EnvString As String
Dim Indx As Integer
Dim Path2000RegKey As CRegistryKey
Dim bl As Boolean

If IsWindows2000 And UCase$(envTopic) = "PATH" Then
  Set Path2000RegKey = New CRegistryKey
  bl = Path2000RegKey.OpenKey(HKEY_LM, "SYSTEM\CurrentControlSet\Control\Session Manager\Environment")
  If bl Then
     'MsgBox envTopic & "=" & Path2000RegKey.Value(envTopic)
     GetEnvString = Path2000RegKey.value(envTopic)
  Else
     GetEnvString = ""
  End If
  Path2000RegKey.CloseKey
Else
  Indx = 1
  EnvString = Environ(Indx)   ' 取得环境变量。
  While EnvString <> ""
     If UCase$(Left(EnvString, Len(envTopic) + 1)) = (UCase$(envTopic) + "=") Then
        GetEnvString = Mid$(EnvString, Len(envTopic) + 2)
        Exit Function
     Else
        Indx = Indx + 1
     End If
     EnvString = Environ(Indx)
  Wend
  GetEnvString = ""
End If
End Function


Public Sub OutToTextFile(ByVal commFile As String, ByVal IsAppendMode As Boolean, ByVal lineStrs As Variant, ByVal QuoteIt As Boolean, Optional ByVal ChToSTR As Boolean = False)
'DoneStr为结果值，写入消息文件
'QuoteIt意为是否在结果上加引号
'ChToStr意为是否强制转为字符串
 Dim fn As Integer
 Dim i As Long
 Dim bIsArray As Boolean
 '
 If IsEmpty(lineStrs) Or IsNull(lineStrs) Then Exit Sub
 fn = FreeFile()
 If IsAppendMode Then
    Open commFile For Append As fn
 Else
    Open commFile For Output As fn
 End If
   '
 bIsArray = IsArray(lineStrs)
 '
 If QuoteIt Then
   If bIsArray Then
        For i = LBound(lineStrs) To UBound(lineStrs)
            If ChToSTR Then
               Write #fn, CStr(lineStrs(i))
            Else
               Write #fn, lineStrs(i)
            End If
        Next i
   Else
        If ChToSTR Then
           Write #fn, CStr(lineStrs(i))
        Else
           Write #fn, lineStrs(i)
        End If
   End If
 Else
   If bIsArray Then
        For i = LBound(lineStrs) To UBound(lineStrs)
            If ChToSTR Then
               Print #fn, CStr(lineStrs(i))
            Else
               Print #fn, lineStrs(i)
            End If
        Next i
   Else
        If ChToSTR Then
           Print #fn, CStr(lineStrs)
        Else
           Print #fn, lineStrs
        End If
   End If
 End If
 '
 Close fn
  
End Sub


Public Function ArrayToStr(ByVal ssa, Optional ByVal SepChar As String = ",", Optional ByVal ShowMessage As Boolean = False) As String
  Dim i As Integer
  Dim ss As String
  ss = ""
  If Not IsNull(ssa) And Not IsEmpty(ssa) Then
    If LBound(ssa) <= UBound(ssa) Then
       For i = LBound(ssa) To UBound(ssa)
          If ss = "" Then
             ss = ssa(i)
          Else
            ss = ss + SepChar + ssa(i)
          End If
       Next i
    End If
  End If
  If ShowMessage Then MsgBox ss, vbInformation, "ArrayToStr()"
  ArrayToStr = ss
End Function


Public Function ExtPathForLisp(ByVal ss As String) As String
   Dim rs As String
   Dim ach As String
   ach = ""
   While ss <> ""
      ach = Left(ss, 1)
      If ach = "\" Then
         rs = rs & "\\"
      Else
         rs = rs & ach
      End If
      ss = Mid(ss, 2)
  Wend
   ExtPathForLisp = rs

End Function