strfun.bas

此文档为VB公共模块

Attribute VB_Name = "StrFun"
'************************************************************
'*  作者：谢建军                                            *
'*  创建日期：2002年11月18日  20：47                        *
'************************************************************
'*  1.StrChg(ByVal C_beChgStr As String,                    *
'*           ByVal C_SeachStr As String,                    *
'*           ByVal C_ChgStr As String)                      *
'*  2.StrCount(ByVal C_BeSeachStr As String,                *
'*             ByVal C_SeachStr As String)                  *
'*  3.GetPyname(ByVal C_ChineseStr As String)               *
'*  4.GetFixStr(ByVal C_Str As String,                      *
'*              ByVal C_Len As Integer,                     *
'*              ByVal C_THChar As String,                   *
'*     Optional ByVal C_Aling As StrAling)                  *
'*  5.GetUnicodeCount(ByVal tmpString As String)            *
'*  6.SupSplit(ByVal cString As String,                     *
'*             ByVal cAlternation As String)                *
'*  7.'阴阳历的转换1900-2011                                *
'*    GetYLDate(tYear As Integer,                           *
'*              tMonth As Integer,                          *
'*              tDay As Integer,                            *
'*              YLyear As String,                           *
'*              YLShuXing As String,                        *
'*              Optional IsGetGl As Boolean)                *
'************************************************************
Public Enum StrAling
  AlingLeft
  AlingRight
End Enum

'*******(1)******
'用指定字符串替换另一字符串中的指定字符串
'****************
Public Function StrChg(ByVal C_beChgStr As String, ByVal C_SeachStr As String, ByVal C_ChgStr As String) As String
  Dim t_i As Integer
  t_i = InStr(1, C_beChgStr, C_SeachStr, vbTextCompare)
  Do Until t_i = 0
    C_beChgStr = Left(C_beChgStr, t_i - 1) + C_ChgStr + mID$(C_beChgStr, t_i + Len(C_SeachStr))
    t_i = InStr(t_i + Len(C_ChgStr), C_beChgStr, C_SeachStr, vbTextCompare)
  Loop
  StrChg = C_beChgStr
End Function
'**********(2)************
'返回指定字符串在另一字符串出现的次数
'*************************
Public Function StrCount(ByVal C_BeSeachStr As String, ByVal C_SeachStr As String) As Integer
  Dim t_i As Integer
  Dim T_count As Integer

  If Len(C_BeSeachStr) = 0 Then
    StrCount = 0
    Exit Function
  End If

  If Len(C_SeachStr) = 0 Then
    StrCount = -1
    Exit Function
  End If

  t_i = InStr(1, C_BeSeachStr, C_SeachStr, vbTextCompare)
  T_count = 0
  Do Until t_i = 0
    T_count = T_count + 1
    t_i = InStr(t_i + Len(C_SeachStr), C_BeSeachStr, C_SeachStr, vbTextCompare)
  Loop
  StrCount = T_count
End Function

'************(3)**********
'返回指定字符串的拼音字符串
'*************************
Public Function GetPyname(ByVal C_ChineseStr As String) As String
Dim T_Str As String: T_Str = C_ChineseStr
Dim T_LenStr As Integer: T_LenStr = Len(C_ChineseStr)
Dim T_CharAscCode As Integer
Dim T_loop As Integer

Dim T_RetStr As String: T_RetStr = ""

For T_loop = 1 To T_LenStr
  T_CharAscCode = Asc(mID$(T_Str, T_loop, 1))
  If T_CharAscCode > 0 Then
    T_RetStr = T_RetStr + mID$(T_Str, T_loop, 1)
  Else
    If T_CharAscCode >= Asc("啊") And T_CharAscCode < Asc("芭") Then
      T_RetStr = T_RetStr + "A"
      GoTo goon
    End If
    If T_CharAscCode >= Asc("芭") And T_CharAscCode < Asc("擦") Then
      T_RetStr = T_RetStr + "B"
      GoTo goon
    End If
    If T_CharAscCode >= Asc("擦") And T_CharAscCode < Asc("搭") Then
      T_RetStr = T_RetStr + "C"
      GoTo goon
    End If
    If T_CharAscCode >= Asc("搭") And T_CharAscCode < Asc("蛾") Then
      T_RetStr = T_RetStr + "D"
      GoTo goon
    End If
    If T_CharAscCode >= Asc("蛾") And T_CharAscCode < Asc("发") Then
      T_RetStr = T_RetStr + "E"
      GoTo goon
    End If
    If T_CharAscCode >= Asc("发") And T_CharAscCode < Asc("噶") Then
      T_RetStr = T_RetStr + "F"
      GoTo goon
    End If
    If T_CharAscCode >= Asc("噶") And T_CharAscCode < Asc("哈") Then
      T_RetStr = T_RetStr + "G"
      GoTo goon
    End If
    If T_CharAscCode >= Asc("哈") And T_CharAscCode < Asc("击") Then
      T_RetStr = T_RetStr + "H"
      GoTo goon
    End If
    If T_CharAscCode >= Asc("击") And T_CharAscCode < Asc("喀") Then
      T_RetStr = T_RetStr + "J"
      GoTo goon
    End If
    If T_CharAscCode >= Asc("喀") And T_CharAscCode < Asc("垃") Then
      T_RetStr = T_RetStr + "K"
      GoTo goon
    End If
    If T_CharAscCode >= Asc("垃") And T_CharAscCode < Asc("妈") Then
      T_RetStr = T_RetStr + "L"
      GoTo goon
    End If
    If T_CharAscCode >= Asc("妈") And T_CharAscCode < Asc("拿") Then
      T_RetStr = T_RetStr + "M"
      GoTo goon
    End If
    If T_CharAscCode >= Asc("拿") And T_CharAscCode < Asc("哦") Then
      T_RetStr = T_RetStr + "N"
      GoTo goon
    End If
    If T_CharAscCode >= Asc("哦") And T_CharAscCode < Asc("啪") Then
      T_RetStr = T_RetStr + "O"
      GoTo goon
    End If
    If T_CharAscCode >= Asc("啪") And T_CharAscCode < Asc("期") Then
      T_RetStr = T_RetStr + "P"
      GoTo goon
    End If
    If T_CharAscCode >= Asc("期") And T_CharAscCode < Asc("然") Then
      T_RetStr = T_RetStr + "Q"
      GoTo goon
    End If
    If T_CharAscCode >= Asc("然") And T_CharAscCode < Asc("撒") Then
      T_RetStr = T_RetStr + "R"
      GoTo goon
    End If
    If T_CharAscCode >= Asc("撒") And T_CharAscCode < Asc("塌") Then
      T_RetStr = T_RetStr + "S"
      GoTo goon
    End If
    If T_CharAscCode >= Asc("塌") And T_CharAscCode < Asc("挖") Then
      T_RetStr = T_RetStr + "T"
      GoTo goon
    End If
    If T_CharAscCode >= Asc("挖") And T_CharAscCode < Asc("昔") Then
      T_RetStr = T_RetStr + "W"
      GoTo goon
    End If
    If T_CharAscCode >= Asc("昔") And T_CharAscCode < Asc("压") Then
      T_RetStr = T_RetStr + "X"
      GoTo goon
    End If
    If T_CharAscCode >= Asc("压") And T_CharAscCode < Asc("匝") Then
      T_RetStr = T_RetStr + "Y"
      GoTo goon
    End If
    If T_CharAscCode >= Asc("匝") And T_CharAscCode < 0 Then
      T_RetStr = T_RetStr + "Z"
      GoTo goon
    End If
    T_RetStr = T_RetStr + "?"
  End If
goon:
Next
GetPyname = UCase$(T_RetStr)
End Function
'**************(4)************
'返回定长字符串
'*****************************
Public Function GetFixStr(ByVal C_Str As String, ByVal C_Len As Integer, ByVal C_THChar As String, Optional ByVal C_Aling As StrAling) As String
C_Str = Trim$(C_Str)
If Len(C_Str) < C_Len Then
  If C_Aling = AlingRight Then
    GetFixStr = C_Str + String(C_Len - Len(C_Str), C_THChar)
  Else
    GetFixStr = String(C_Len - Len(C_Str), C_THChar) + C_Str
  End If
Else
  GetFixStr = C_Str
End If
End Function

'***************(5)***************
'检查字符串中的汉字，返回len(tmpString)+包函在其中的汉字个数
'*********************************
Public Function GetUnicodeCount(ByVal tmpString As String) As Long
Dim ChineseNum As Long, i As Long, tmpStrLen As Long
Dim lsChar As String
ChineseNum = 0
tmpStrLen = Len(tmpString)
For i = 1 To tmpStrLen
  lsChar = mID$(tmpString, i, 1)
  If Asc(lsChar) < 0 Then
    ChineseNum = ChineseNum + 1
  End If
Next
GetUnicodeCount = ChineseNum
End Function


'***************(6)***************
'返回字符串数组
'*********************************
Public Function SupSplit(ByVal cString As String, ByVal cAlternation As String) As String()
Dim tAlternation() As String, tI As Integer, tII As Integer, tTmpVal As String
tAlternation = Split(cAlternation, "|", -1, vbTextCompare)
For tI = 0 To UBound(tAlternation)
  For tII = tI To UBound(tAlternation)
    If Len(tAlternation(tI)) < Len(tAlternation(tII)) Then
      tTmpVal = tAlternation(tI)
      tAlternation(tI) = tAlternation(tII)
      tAlternation(tII) = tTmpVal