stringmodule.bas

适合乡镇供电所使用电费处理系统v3 软件

Attribute VB_Name = "StringModule"
Option Explicit

Private Declare Function IsCharAlphaNumeric Lib _
   "USER32" Alias "IsCharAlphaNumericA" (ByVal cChar As Byte) As Long
Private Declare Function IsCharAlpha Lib "USER32" Alias "IsCharAlphaA" (ByVal cChar As Byte) As Long

'/////////指定删除字符串中字符////////
Function StringCleaner(s As String, _
    Search As String) As String
        Dim I As Integer, res As String
        res = s
        Do While InStr(res, Search)
            I = InStr(res, Search)
            res = Left(res, I - 1) & _
                Mid(res, I + 1)
        Loop
        StringCleaner = res
End Function


'///////////怎样取得一个字符串在另外一个字符串中出现的次数？///////
'//////缺点：无法统计并排的字符如ABCDD中的DD只为一次
Public Function sCount(String1 As String, String2 As String) As Integer
    Dim I As Integer, iCount As Integer
    I = 1
    Do
           If (I > Len(String1)) Then Exit Do
           I = InStr(I, String1, String2, vbTextCompare)
           If I Then
              iCount = iCount + 1
              I = I + 2
              DoEvents
           End If
    Loop While I
    sCount = iCount
End Function

'//////////怎样在一个字符串中删除里面的另外一个字符串？
Public Function sRemove(String1 As String, String2 As String)
    Dim I As Integer
    I = 1
    Do
      If (I > Len(String1)) Then Exit Do
      I = InStr(I, String1, String2)
      If I Then
         String1 = Left$(String1, I - 1) + Mid$(String1, I + Len(String2) + 1)
         I = I + 2
         DoEvents
      End If
     Loop While I
End Function

'/////////怎样在一个字符串中替换里面的另外一个字符串？
Public Sub sReplace(String1 As String, String2 As String, RepString As String)
    Dim I As Integer
    I = 1
    Do
     If (I > Len(String1)) Then Exit Do
     I = InStr(I, String1, String2)
     If I Then
        String1 = Left$(String1, I - 1) + RepString + Mid$(String1, I + Len(String2))
        I = I + 2
        DoEvents
     End If
    Loop While I
End Sub
 
'/////////□ 如何计算一个字符串中的行数？
Function CountStringLine(src_string As String) As Integer
On Error Resume Next
Dim string_flag As Integer
Dim line_cnt As Integer
Dim test_string As String
line_cnt = 0  '初始--> 行数为1
string_flag = 1  '标志为1
test_string = src_string
DoEvents
Do
 line_cnt = line_cnt + 1
 string_flag = InStr(test_string, vbCrLf)  '判断回车换行
 test_string = Right(test_string, Len(test_string) - string_flag - 1)
Loop Until string_flag <= 0
CountStringLine = line_cnt
End Function
 
'////////////字符串翻转////////////
'示例:OverturnStr(string)
'/////////////////////////////////
Static Function OverturnStr(Revstr As String) As String
    Dim doreverse As Long
    OverturnStr = ""
    For doreverse = Len(Revstr) To 1 Step -1
        OverturnStr = OverturnStr & Mid$(Revstr, doreverse, 1)
    Next
End Function
 
'////////////处理sql中的查询/////////////////
'以后在动态生成 Select 语句， 使用：
'  SqlString = "Select * from myBas where Name  = " & CheckString(Text1)
'///////////////////////////////////////////
Public Function CheckSQL(s) As String
    Dim Pos As Integer
    Pos = InStr(s, "'")
    While Pos > 0
    s = Mid(s, 1, Pos) & "'" & Mid(s, Pos + 1)
    Pos = InStr(Pos + 2, s, "'")
    Wend
    CheckSQL = "'" & s & "'"
End Function
 
'//////////□ 如何从一个字符串中读取一行字符？
Function ReadStringLine(src_str As String, lineno As Integer) As String
On Error Resume Next
Dim string_flag As Integer
Dim line_cnt As Integer
Dim test_string As String
Dim ret_string As String
line_cnt = 0  '初始--> 行数为1
string_flag = 1  '标志为1
test_string = Right(src_str, 2)
If test_string <> vbCrLf Then
 test_string = src_str + vbCrLf
Else
 test_string = src_str
End If
DoEvents
Do
 line_cnt = line_cnt + 1
 string_flag = InStr(test_string, vbCrLf)
 ret_string = Left(test_string, string_flag)
 test_string = Right(test_string, Len(test_string) - string_flag - 1)
Loop Until lineno <= line_cnt
'If line_cnt = 1 Then
'  ReadStringLine = ret_string
'Else
ReadStringLine = Left(ret_string, Len(ret_string) - 1)
'End If
End Function

Function FileExists(fname$) As Boolean
    On Error Resume Next  '设置错误处理
    Dim X As Integer
 
    X = FreeFile      '取得一个空闲文件句柄
    Open fname$ For Input As X     '试图打开该文件
    If Err = 0 Then        '如果打开成功
        FileExists = True
    Else                   '否则
        FileExists = False
    End If
    Close X
End Function

'
' 如果参数s中的字符全是数字则返回0
' 否则将返回第一个非数字出现的位置
' 例如 IsStringAlpha("asdf12a") = 1
Function IsStringNumeric(s As String) As Long
   Dim I As Long
   Dim j As Byte
   
   For I = 1 To Len(s)
      j = Asc(Mid$(s, I, 1))
      If IsCharAlphaNumeric(j) = 1 Then
         If IsCharAlpha(j) = 1 Then
            IsStringNumeric = I
            Exit Function
         End If
      Else
         IsStringNumeric = I
         Exit Function
      End If
   Next I
   
   IsStringNumeric = 0
End Function

'快速读取文件
Function ReadFile(ByVal Filename As String) As String
    Dim handle As Integer
    
    ' 判断文件存在性
    If Len(Dir$(Filename)) = 0 Then
       Err.Raise 53 '文件没有找到
    End If
    
    ' 以binary模式打开文件
    handle = FreeFile
    Open Filename$ For Binary As #handle
    ' 读取内容，关闭文件
    ReadFile = Space$(LOF(handle))
    Get #handle, , ReadFile
    Close #handle
End Function


'从包含电价名称中分割出数字电价
Public Function PriceStr(ByVal sString As String, ByVal LocaStr As String)
   Dim n As Integer, m As Integer
   For n = 1 To Len(sString)
       m = InStrRev(sString, LocaStr, -1)
   Next n
   PriceStr = Right(sString, Len(sString) - m + 2)
End Function

'从包含电价名称中分割出字符电价
Public Function PriceName(ByVal sString As String, ByVal LocaStr As String)
   Dim n As Integer, m As Integer
   For n = 1 To Len(sString)
       m = InStrRev(sString, LocaStr, -1)
   Next n
   PriceName = Left(Left(sString, m - 2), convert_str((Left(sString, m - 2))))
End Function

'数字转二进制
Public Function convDecToBin(ByVal curNumber As Currency) As String
  On Error GoTo convDecToBin_end
  Dim strBin As String
  Dim I As Long
  For I = 64 To 0 Step -1
    If Int(curNumber / (2 ^ I)) = 1 Then
      strBin = strBin & "1"
      curNumber = curNumber - (2 ^ I)
    Else
      If strBin <> "" Then
        strBin = strBin & "0"
      End If
    End If
  Next
  convDecToBin = strBin

convDecToBin_end:
  If Err <> 0 Or strBin = "" Then convDecToBin = "-E-"
  Exit Function
End Function

'检查是否是数字,不允许小数点
'用法: Call CheckIsNumber(Ctorl)
Public Sub CheckIsNumber(TextBoxCotrl As Control)
'   Dim TestInput As Long
   On Error GoTo Inputwrong
'   TestInput = TextBoxCotrl.Text
'   If TestInput < 0 Or TestInput > 9999 Then
   If IsStringNumeric(TextBoxCotrl.Text) <> 0 Then
      MsgBox "请输入0-9之间的数字!", vbCritical, "系统提示"
      TextBoxCotrl.SetFocus
      SendKeys "{Home}+{End}"
      Exit Sub
   End If
   Exit Sub

Inputwrong:
  If Err.Number = 13 Then
     MsgBox "请输入0-9之间的数字!", vbCritical, "系统提示"
     TextBoxCotrl.SetFocus
     SendKeys "{Home}+{End}"
     Exit Sub
  End If
End Sub

'检查是否是数字,允许小数点
'用法: Call CheTxt(Ctorl)
 Public Function CheTxt(CheT As String)
   Dim I As Long
   Dim j As Integer
   On Error GoTo Inputwrong
   For I = 1 To Len(CheT)
      j = Asc(Mid$(CheT, I, 1))
      If j = 46 Or j = 48 Or j = 49 Or j = 50 Or j = 51 Or j = 52 Or j = 53 Or j = 54 Or j = 55 Or j = 56 Or j = 57 Then
      Else
            MsgBox "请输入0-9之间的数字!", vbCritical, "系统提示"
            SendKeys "{Home}+{End}"
            Exit Function
      End If
   Next I
   Exit Function

Inputwrong:
  If Err.Number = 13 Then
     MsgBox "请输入0-9之间的数字!", vbCritical, "系统提示"
     SendKeys "{Home}+{End}"
     Exit Function
  End If
End Function

'===============================================================
' 名称： 数字转大写
'        得到一位数字 N1 的汉字大写
'        0 返回 ""
Private Function cch(N1) As String
Select Case N1
  Case 0
    cch = "零"
  Case 1
    cch = "壹"
  Case 2
    cch = "贰"
  Case 3
    cch = "叁"
  Case 4
    cch = "肆"
  Case 5
    cch = "伍"
  Case 6
    cch = "陆"
  Case 7
    cch = "柒"
  Case 8
    cch = "捌"
  Case 9
    cch = "玖"
End Select
End Function

Private Function CH(N1) As String
Select Case N1
  Case 0
    CH = "0"
  Case 1
    CH = "1"
  Case 2
    CH = "2"
  Case 3
    CH = "3"
  Case 4
    CH = "4"
  Case 5
    CH = "5"
  Case 6
    CH = "6"
  Case 7
    CH = "7"
  Case 8
    CH = "8"
  Case 9
    CH = "9"
End Select
End Function


'名称： ChMoneyY
'       得到数字 N1 的汉字大写
'       最大为 千万位
'       O 返回 ""
Public Function ChMoneyY(N1) As String
Dim tMoney As String
Dim lMoney As String
Dim tn
Dim s1 As String '临时STRING 小数部分
Dim s2 As String '
Dim ST1 As String
Dim t1 As String
Dim s3 As String


If N1 = 0 Then
  ChMoneyY = " "
  Exit Function
End If
If N1 < 0 Then
  ChMoneyY = "负" + ChMoney(Abs(N1))
  Exit Function
End If
tMoney = Trim(Str(N1))
tn = InStr(tMoney, ".")
s1 = ""

If tn <> 0 Then
  ST1 = Right(tMoney, Len(tMoney) - tn)
  If ST1 <> "" Then
    t1 = Left(ST1, 1)
    ST1 = Right(ST1, Len(ST1) - 1)
    If t1 <> "0" Then
      s1 = s1 + cch(Val(t1)) + "角"
    End If
    If ST1 <> "" Then
     t1 = Left(ST1, 1)
     s1 = s1 + cch(Val(t1)) + "分"
    End If
  End If
  ST1 = Left(tMoney, tn - 1)
Else
  ST1 = tMoney
End If


's1 = "元" + s1
s2 = ""
If ST1 <> "" Then
  t1 = Right(ST1, 1)
  ST1 = Left(ST1, Len(ST1) - 1)
  s2 = cch(Val(t1)) + s2
End If

If ST1 <> "" Then
  t1 = Right(ST1, 1)
  ST1 = Left(ST1, Len(ST1) - 1)
  If t1 <> "0" Then
    s2 = cch(Val(t1)) + "拾" + s2
  Else
    If Left(s2, 1) <> "零" Then s2 = "零" + s2
  End If
End If

If ST1 <> "" Then
  t1 = Right(ST1, 1)
  ST1 = Left(ST1, Len(ST1) - 1)
  If t1 <> "0" Then
    s2 = cch(Val(t1)) + "佰" + s2
  Else
    If Left(s2, 1) <> "零" Then s2 = "零" + s2
  End If
End If

If ST1 <> "" Then
  t1 = Right(ST1, 1)
  ST1 = Left(ST1, Len(ST1) - 1)
  If t1 <> "0" Then
  s2 = cch(Val(t1)) + "仟" + s2
  Else
    If Left(s2, 1) <> "零" Then s2 = "零" + s2
  End If
End If

s3 = ""
If ST1 <> "" Then
  t1 = Right(ST1, 1)
  ST1 = Left(ST1, Len(ST1) - 1)
  s3 = cch(Val(t1)) + s3
End If


If ST1 <> "" Then
  t1 = Right(ST1, 1)
  ST1 = Left(ST1, Len(ST1) - 1)
  If t1 <> "0" Then