strings.cls

非常实用的VB函数,包括SQL字符转换

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "FunctionLib"
Attribute VB_GlobalNameSpace = True
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Enum ICKeyDataType
    StringType = 1
    NumericType = 2
End Enum
Enum FieldType
    efoStringType = 1
    efoNumericType = 2
    efoDataType = 3
    efoBooleanType = 4
End Enum
Enum ICKeyAddOrEdit
    recAdd = 1
    recEdit = 2
End Enum

Public Function TheMonthFirstDay(dt As Date) As Date
 If IsNull(dt) Then dt = Date
 TheMonthFirstDay = dt - Day(dt) + 1
End Function
'
Public Function TheMonthLastDay(dt As Date) As Date
 Dim I As Integer
 If IsNull(dt) Then dt = Date
 I = Month(dt)
 While Month(dt) = I
  dt = dt + 1
 Wend
 TheMonthLastDay = dt - 1
End Function

'*****************************************************************************************
Private Function MoneyLength(a As Double) As Integer
  MoneyLength = Len(Trim(Str(a)))
End Function
Private Function TakePoint(a As Double) As Integer
  Dim I As Integer
  Dim temps As String
  
  TakePoint = 0
  temps = Trim(Str(a))
  For I = 1 To MoneyLength(a)
    If Mid(temps, I, 1) = "." Then
      TakePoint = I
      Exit For
    End If
  Next I
  
End Function

Public Function TranMark(mString As Variant) As String
    If InStr(1, mString, "'") <> 0 Then
        '将每个'替换成两个'
        Dim LocaCode As Long
        LocaCode = InStr(1, mString, "'")
        Do While LocaCode <> 0
            Mid(mString, LocaCode, 1) = "’"
            mString = Left(mString, LocaCode - 1) & "''" & Mid(mString, LocaCode + 1)
            LocaCode = InStr(LocaCode + 2, mString, "'")
        Loop
    End If
    '''''''
    TranMark = mString
End Function
Public Function GetMark(ByVal FieldType As FieldType) As String
    '根据字段类型返回SQL定界符
    Select Case FieldType
    Case efoDataType, efoStringType
        GetMark = "'"
    Case efoNumericType, efoBooleanType
        GetMark = ""
    Case Else
        GetMark = "'"
    End Select
End Function
Public Function ToChineseNum(ByVal n As Integer) As String
   Select Case n
     Case 0
       ToChineseNum = "零"
     Case 1
       ToChineseNum = "一"
     Case 2
       ToChineseNum = "二"
     Case 3
       ToChineseNum = "三"
     Case 4
       ToChineseNum = "四"
     Case 5
       ToChineseNum = "五"
     Case 6
       ToChineseNum = "六"
     Case 7
       ToChineseNum = "七"
     Case 8
       ToChineseNum = "八"
     Case 9
       ToChineseNum = "九"
    End Select
     
End Function
Private Function ToChinese(a As Integer) As String
  If a > 9 Or a < 0 Then MsgBox "对不起，您输的某位不是数字！"
   Select Case a
     Case 0
       ToChinese = "零"
     Case 1
       ToChinese = "壹"
     Case 2
       ToChinese = "贰"
     Case 3
       ToChinese = "叁"
     Case 4
       ToChinese = "肆"
     Case 5
       ToChinese = "伍"
     Case 6
       ToChinese = "陆"
     Case 7
       ToChinese = "柒"
     Case 8
       ToChinese = "捌"
     Case 9
       ToChinese = "玖"
    End Select
     
End Function
Public Function ToRMB(ByVal Number As Double, Optional ByVal JD As Boolean) As String
'1、不考虑数字中有"，"的情况
'2、没有考虑数末尾四舍五入的情况。

   Dim MillionFlag, GPlace, I, j, OnlyOne, Different As Integer
   Dim Tenth, Hundredth As Integer
   Dim Unit(96), PointPlace, GetFirst As String
   Dim NegFlag, NoInt As Boolean
   'PointPlace为小数点的位置
   'GetFirst为目标串的第一个字符
   'OnlyOne为每次取出的单个字符
   'Different为小数位数
   
   NegFlag = False '标识是否负数：“1”为负数。如果是负数，后面要加上一个“借”字
   NoInt = False   '标识是个纯小数
   
   Unit(0) = "拾": Unit(1) = "亿": Unit(2) = "仟": Unit(3) = "佰"
   Unit(4) = "拾": Unit(5) = "万": Unit(6) = "仟": Unit(7) = "佰":
   Unit(8) = "拾": Unit(9) = "圆": Unit(10) = "角": Unit(11) = "分"
   
   If Number < 0 Then
     NegFlag = True
     Number = Abs(Number)
   End If
   
   If Number = 0 Then
     ToRMB = "零"
     Exit Function
   End If
   
   ToRMB = ""
   PointPlace = TakePoint(Number)
   If PointPlace - 1 > 10 Then
     ToRMB = "****数据溢出****"
     Exit Function
   End If
   
   If (PointPlace = 1) Or (PointPlace = 2 And Mid(Trim(Str(Number)), PointPlace + 1, 1) = "0") Then
     NoInt = True
     GoTo DecimalProcessing
   End If
   
   If PointPlace = 0 Then PointPlace = MoneyLength(Number) + 1
   '无小数点，即为整数的情况
   
   GPlace = PointPlace - 1
   j = PointPlace - 1
   For I = 9 To 10 - GPlace Step -1
        OnlyOne = Int(Val(Mid(Trim(Str(Number)), j, 1)))
        
        '如果数字是零，它对应的单位就不要显示出来**********************
        '但若是“圆”，则就算数字是零，也要显示
        If OnlyOne <> 0 Then
          ToRMB = Unit(I) & ToRMB
        Else
          If I = 9 Then ToRMB = Unit(I) & ToRMB
        End If
        
        
        '在多个零的情况下，也要显示‘亿’和‘万’***********************
        If (I = 5 Or I = 1) And Not (Mid(ToRMB, 1, 1) = "万" And Unit(I) = "万") And Not (Mid(ToRMB, 1, 1) = "亿" And Unit(I) = "亿") Then
           ToRMB = Unit(I) & ToRMB
        End If
        
        '如果有多个零连续的时候，只显示一个零**************************
        GetFirst = Mid(Trim(ToRMB), 1, 1)
        If GetFirst <> "零" And Not (GetFirst = "圆" And OnlyOne = 0) And Not (GetFirst = "万" And OnlyOne = 0) And Not (GetFirst = "亿" And OnlyOne = 0) Then
            ToRMB = ToChinese(Int(OnlyOne)) & ToRMB
        End If
        
        j = j - 1
  Next I

'如果万，十万，百万，千万位上的数字全是0，且有亿存在，则要去掉单位万
  If PointPlace > 9 Then
    If Mid(Str(Number), PointPlace - 8, 4) = "0000" Then
    For I = 1 To Len(ToRMB)
      If Mid(ToRMB, I, 1) = "万" Then
        MillionFlag = I
        Exit For
      End If
    Next I
    ToRMB = Mid(ToRMB, 1, MillionFlag - 1) & Mid(ToRMB, MillionFlag + 1)
    End If
  End If
    
DecimalProcessing:

  Tenth = Int(Val(Mid(Trim(Str(Number)), PointPlace + 1, 1)))
  Hundredth = Int(Val(Mid(Trim(Str(Number)), PointPlace + 2, 1)))
  If PointPlace < MoneyLength(Number) Then
    Different = MoneyLength(Number) - PointPlace
    If Different > 2 Then
      Different = 2
    End If
'    MsgBox Mid(Str(a), PointPlace + 2, 2)
    If Different = 2 And Mid(Str(Number), PointPlace + 2, 2) = "00" Then
      If NoInt Then ToRMB = "零"
      Exit Function
    End If
    
    If Different = 1 Or Different = 2 Then
      If Different = 1 Then
        ToRMB = ToRMB & ToChinese(Int(Tenth))
        If ToChinese(Int(Tenth)) <> "零" Then
          ToRMB = ToRMB & "角"
        End If
      ElseIf Different = 2 Then
        ToRMB = ToRMB & ToChinese(Int(Tenth))
        If ToChinese(Int(Tenth)) <> "零" Then
          ToRMB = ToRMB & "角"
        End If
        ToRMB = ToRMB & ToChinese(Int(Hundredth))
        If ToChinese(Int(Hundredth)) <> "零" Then
          ToRMB = ToRMB & "分"
        End If
      End If
    Else
        ToRMB = ToRMB & "整"
    End If
  Else
    ToRMB = ToRMB & "整"
  End If
  If JD Then
    If NegFlag Then
      ToRMB = "借：" & ToRMB
    Else
      ToRMB = "贷：" & ToRMB
    End If
  End If
  
End Function

'*****************************************************************************************
Public Function GetPrimaryKey(ByRef cn As Connection, ByRef TableName As String, ByRef FieldName As String, ByRef KeyStr As String, Optional ByRef FormatStr As String, Optional ByRef hStr As String, Optional ByVal CheckFormat As Boolean) As String
     ''''''''''''所需资源''''''''''''''
     '表名:      PrimaryKey
     '字段:      TableName(C),FieldName(C),KeyStr(C),FormatStr(C)
     Dim gRegCode As Boolean
     
     If cn.State = 0 Then
        MsgBox "无效的数据库连接!"
        GetPrimaryKey = ""
        Exit Function
     End If
     If Trim(TableName) = "" Then
        MsgBox "无效的表名!"
        GetPrimaryKey = ""
        Exit Function
     End If
     If Trim(FieldName) = "" Then
        MsgBox "无效的字段名!"
        GetPrimaryKey = ""
        Exit Function
     End If
'     On Error GoTo er
     Dim strSQL As String, rs As New Recordset, Exist As Single
     KeyStr = Trim(KeyStr)
     ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
     If KeyStr = "自动" Then
        strSQL = "Select KeyStr,FormatStr from PrimaryKey where TableName='" & TableName & "' And FieldName='" & FieldName & "'"
        rs.Open strSQL, cn, adOpenStatic, adLockReadOnly
        If Not rs.EOF Then
            If FormatStr = "" Then
               FormatStr = IIf(Trim(rs!FormatStr) <> "", Trim(rs!FormatStr), "###")
            End If
            If CodeIsFormated(Trim(rs!KeyStr), FormatStr) Then
               KeyStr = GetNextFormatCode(Trim(rs!KeyStr), FormatStr)