strings.cls

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

        If FFormat = "" Then
            FFormat = IIf(Trim(rs!FFormat) <> "", Trim(rs!FFormat), "######")
        End If
        If FBillType > 0 Then
           AttachFilter = "FBillType = " & FBillType & IIf(Trim(AttachFilter) <> "", " And ", "") & AttachFilter
        End If
     Else
        MsgBox "无效的单据编码，请先注册单据编码！", vbExclamation, "系统提示"
        rs.Close
        Set rs = Nothing
        Exit Function
     End If

     TranMark OldICKey
     If ICKey = "自动" Or ICKey = "自动生成" Then
        If CodeIsFormated(Trim(rs!FMaxKey), FFormat) Then
            ICKey = GetNextFormatCode(Trim(rs!FMaxKey), FFormat)
        Else
            ICKey = GetNextFormatCode(GetNextFormatCode("", FFormat), FFormat)
        End If
        rs.Close
        If ICKey = "" Then
           MsgBox "编码已满，请拓展编码格式！", 48, "系统提示"
           GetBillNo = ""
           Exit Function
        End If
        Do While True  '''''''''''*
            strSQL = "Select Count(" & FieldName & ") As Exist from " & TableName & _
                    " Where " & FieldName & "='" & ICKey & "'" & _
                    IIf(AddOrEdit = recEdit, IIf(Trim(OldICKey) <> "", _
                    " And " & FieldName & "<>'" & OldICKey & "'", ""), "") & _
                    IIf(Trim(AttachFilter) <> "", " And ", "") & AttachFilter
            rs.Open strSQL, ActiveConnection, adOpenStatic, adLockReadOnly
            If rs!Exist = 0 Then
                rs.Close
                Exit Do
            End If
            rs.Close
            ICKey = GetNextFormatCode(Trim(ICKey), FFormat)
            If ICKey = "" Then
                MsgBox "编码已满，请拓展编码格式！", 48, "系统提示"
                GetBillNo = ""
                Exit Function
            End If
        Loop         ''''''''''''*
       
        If IsRegister Then
            ActiveConnection.Execute "Update ICMaxBillNo Set FMaxKey='" & ICKey & "' where FProjID='" & ProjectID & "'"
        End If
        GetBillNo = ICKey
     Else
        rs.Close
        If CheckFormat Then   '需检查用户编码格式
            If Not CodeIsFormated(ICKey, FFormat) Then
                MsgBox "编码不符合格式[" & FFormat & "]！", 48, "系统提示"
                GetBillNo = ""
                Exit Function
            End If
        End If
        mICKey = ICKey
        strSQL = "Select Count(" & FieldName & ") As Exist from " & TableName & _
                 " Where " & FieldName & "='" & TranMark(mICKey) & "'" & _
                     IIf(AddOrEdit = recEdit, IIf(Trim(OldICKey) <> "", _
                     " And " & FieldName & "<>'" & TranMark(OldICKey) & "'", ""), "") & _
                     IIf(Trim(AttachFilter) <> "", " And ", "") & AttachFilter
        rs.Open strSQL, ActiveConnection, adOpenStatic, adLockReadOnly
        If rs!Exist > 0 Then
            rs.Close
            If ExistPromptMsg <> "" Then
                MsgBox ExistPromptMsg, 0 + 48, "操作提示"
            End If
            GetBillNo = ""
            Exit Function
        End If
        rs.Close
        Set rs = Nothing
        GetBillNo = ICKey
     End If
      '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
     Exit Function
er:
     MsgBox "数据库访问错误(或找不到[ICMaxBillNo]表),请检查数据库！[" & err.Description & "]", vbExclamation, "系统提示"
     GetBillNo = ""
End Function

Public Function RegisterBillProj(ActiveConnection As Connection, ProjectID As String, BillType As Integer, _
            TableName As String, FieldName As String, _
            ByVal FieldType As ICKeyDataType, ByVal FFormat As String) As Boolean
    '在ICMaxKey中注册该项目
    If ActiveConnection.State = 0 Or Trim(ProjectID) = "" Or Trim(TableName) = "" Or Trim(FieldName) = "" Then
        MsgBox "无效的参数！", vbExclamation, "系统提示"
        Exit Function
    End If
    On Error GoTo err
    Dim rs As New Recordset
    rs.Open "Select * from ICMaxBillNo where FProjID='" & ProjectID & "'", ActiveConnection, adOpenStatic, adLockReadOnly
    If rs.EOF Then
        ActiveConnection.Execute "Insert into ICMaxBillNo(FProjID,FBillType,FTableName,FFieldName,FMaxKey,FFormat)Values('" & _
                ProjectID & "'," & BillType & ",'" & TableName & "','" & FieldName & "','" & GetNextFormatCode("", FFormat) & "','" & FFormat & "')"
    Else
        ActiveConnection.Execute "Update ICMaxBillNo set FBillType=" & BillType & ",FTableName='" & TableName & _
            "',FFieldName='" & FieldName & "',FFormat='" & FFormat & _
            "' Where  FProjID='" & ProjectID & "'"
    End If
    rs.Close
    Set rs = Nothing
    RegisterBillProj = True
    Exit Function
err:
    MsgBox err.Description
End Function
'*************************************************************************************************
Public Function RegisterTable(ActiveConnection As Connection, TableName As String, FieldName As String, _
            ByVal FieldType As ICKeyDataType, ByVal FFormat As String) As Boolean
    '在ICMaxKey中注册该项目
    If ActiveConnection.State = 0 Or Trim(TableName) = "" Or Trim(FieldName) = "" Then
        MsgBox "无效的参数！", vbExclamation, "系统提示"
        Exit Function
    End If
    On Error GoTo err
    Dim rs As New Recordset
    rs.Open "Select * from ICMaxKey where FTableName='" & TableName & "' And FFieldName='" & FieldName & "'", ActiveConnection, adOpenStatic, adLockReadOnly
    If rs.EOF Then
        ActiveConnection.Execute "Insert into ICMaxKey(FTableName,FFieldName,FFieldType,FMaxKey,FFormat)Values('" & _
                TableName & "','" & FieldName & "','" & FieldType & "','','" & FFormat & "')"
    Else
        ActiveConnection.Execute "Update ICMaxKey set FFieldType=" & FieldType & ", FFormat='" & FFormat & _
            "' Where  FTableName='" & TableName & "' And FFieldName='" & FieldName & "'"
    End If
    rs.Close
    Set rs = Nothing
    RegisterTable = True
    Exit Function
err:
    MsgBox err.Description
End Function

Public Function IsUnique(ActiveConnection As Connection, TableName As String, FieldName As String, _
        ByVal Value As String, Optional ByVal AddOrEdit As ICKeyAddOrEdit = recAdd, _
        Optional ByVal OldValue As String, Optional ByVal AttachFilter As String, _
        Optional ByVal ExistPromptMsg As String = "该数据信息已存在！", _
        Optional ByVal FieldType As ICKeyDataType = StringType) As Boolean
    '用于检查数据的正确性
    Dim rsCheck As New ADODB.Recordset
    Dim Indirect As String
    Dim strSQL As String
    Indirect = IIf(FieldType = StringType, "'", "")
    If AddOrEdit = recAdd Then    '新增模式
       strSQL = "select Count(*) As Exist from " & TableName & " where " & FieldName & "=" & Indirect & TranMark(Value) & Indirect & _
                IIf(Trim(AttachFilter) <> "", " And ", "") & AttachFilter
    Else                            '修改模式
       strSQL = "select count(*) As Exist from " & TableName & " where " & FieldName & "=" & Indirect & TranMark(Value) & Indirect & _
                IIf(Trim(OldValue) <> "", " And " & FieldName & "=" & Indirect & OldValue & Indirect, "") & _
                IIf(Trim(AttachFilter) <> "", " And ", "") & AttachFilter
    End If
    On Error GoTo err
    rsCheck.Open strSQL, ActiveConnection, adOpenStatic, adLockReadOnly
    If rsCheck!Exist > 0 Then
       If Trim(ExistPromptMsg) <> "" Then
            MsgBox ExistPromptMsg, vbInformation, "系统提示"
       End If
    Else
       IsUnique = True
    End If
    rsCheck.Close
    Set rsCheck = Nothing
    Exit Function
err:
    MsgBox err.Description, vbExclamation, "系统错误"
End Function



'************************************************************************************
Public Function IFNull(ByVal ChkValue As Variant, ByVal NullValue As Variant, Optional ByVal Seperate As String, Optional ByVal ChkDate As Boolean = False) As Variant
    On Error Resume Next
    If ChkDate Then
        IFNull = IIf(IsNull(ChkValue), "Null", IIf(Trim(ChkValue) = "" Or Trim(ChkValue) = "-  -" Or Trim(ChkValue) = "00:00:00", "Null", ChkValue))
        If IFNull <> "Null" Then
            If Hour(CDate(IFNull)) <> 0 Or Minute(CDate(IFNull)) <> 0 Or Second(CDate(IFNull)) <> 0 Then
                IFNull = Format(IFNull, "yyyy-MM-dd hh:mm:ss")
            Else
                IFNull = Format(IFNull, "yyyy-MM-dd")
            End If
            If Seperate <> "" Then
                IFNull = Seperate & IFNull & Seperate
            End If
        ElseIf NullValue <> "" And Seperate = "" Then
            IFNull = NullValue
        End If
    Else
        IFNull = IIf(IsNull(ChkValue), NullValue, ChkValue)
        If IFNull = "" And NullValue <> "" Then
            IFNull = NullValue
        End If
        If Seperate <> "" Then IFNull = Seperate & IFNull & Seperate
    End If
End Function

Public Function GetDigit(ByVal StrDigit As String) As Double
Dim mStr As String
Dim I As Integer
mStr = ""
StrDigit = Trim(StrDigit)
For I = 1 To Len(StrDigit)
    mStr = mStr & IIf(IsNumeric(Mid(StrDigit, I, 1)) Or Mid(StrDigit, I, 1) = "." Or Mid(StrDigit, I, 1) = "-" Or Mid(StrDigit, I, 1) = "+", Mid(StrDigit, I, 1), "")
Next
GetDigit = Val(mStr)
End Function
Public Function GetMidString(ByVal DealStr As String, ByVal StartChar As String, Optional ByVal EndChar As String, Optional ByVal Order As Integer = 1) As String
    Dim I As Integer
    Dim FIndex As Integer, NIndex As Integer
    I = InStr(1, DealStr, StartChar)
    If I = 0 Then Exit Function
    FIndex = 1
    NIndex = 0
    If Order <= 0 Then Order = 1
    I = I + 1
    Do While I <= Len(DealStr) And FIndex < Order
        If Mid(DealStr, I, 1) = StartChar Then FIndex = FIndex + 1
        I = I + 1
    Loop
    If FIndex < Order Then Exit Function
    Do While I <= Len(DealStr)
        If Mid(DealStr, I, 1) = StartChar Then NIndex = NIndex + 1
      
        If Mid(DealStr, I, 1) = EndChar Then
            If NIndex = 0 Then
                Exit Function
            Else
                GetMidString = GetMidString & Mid(DealStr, I, 1)
                NIndex = NIndex - 1
            End If
        Else
            GetMidString = GetMidString & Mid(DealStr, I, 1)
        End If
        I = I + 1
    Loop
End Function

'返回定长（字节）字串，后补空
Public Function FixLenStr(ByVal DealStr As String, ByVal BLength As Integer) As String
    Dim TStr As String
    Dim strLen As Integer, I As Integer, CurLen As Integer
    FixLenStr = ""
    DealStr = Trim(DealStr)
    strLen = Len(DealStr)
    CurLen = 0
    For I = 1 To strLen
        If Asc(DealStr) > 0 Then    '单字节
            If BLength - CurLen > 0 Then
                FixLenStr = FixLenStr & Mid(DealStr, 1, 1)
                CurLen = CurLen + 1
                DealStr = Right(DealStr, Len(DealStr) - 1)
            Else
                Exit Function
            End If
        Else                        '双字节
            If BLength - CurLen > 1 Then
                FixLenStr = FixLenStr & Mid(DealStr, 1, 1)
                CurLen = CurLen + 2
                DealStr = Right(DealStr, Len(DealStr) - 1)
            Else
                Exit For
            End If
        End If
    Next
    For I = 1 To BLength - CurLen
        FixLenStr = FixLenStr & " "
    Next
End Function
'生成校验码
Public Function CreatePlu(Digit As Double, Length As Integer) As String
    Dim mStr As String
    mStr = String(Length - 1, "0")
    CreatePlu = Format(Digit, mStr)
    Dim j As Long
    Dim I As Integer
    j = 0
    For I = 1 To Length - 1
     j = j + Val(Mid(CreatePlu, I, 1)) * IIf(I Mod 2 = 1, 7, 9)
    Next
    CreatePlu = CreatePlu & Right(Str(j), 1)
End Function
Public Function Wordbook(ActiveConnection As Connection, ByVal sClassID As Variant, Optional ByVal sWord As Variant, Optional TxtObjhwnd As Long) As String
Dim rs As New Recordset
Dim p As POINTAPI
sClassID = IFNull(sClassID, "PublicSearchID")
'GetCaretPos (p)             '获得当前光标位置
sWord = TranMark(IFNull(sWord, ""))
If sWord <> "" Then     'Save
    ActiveConnection.Execute "Delete Wordbook Where FClassID='" & sClassID & "' And FWord='" & sWord & "'"
    ActiveConnection.Execute "Insert Wordbook(FClassID,FWord) Values ('" & sClassID & "','" & sWord & "')"
    Exit Function
Else                    'Search
    FrmWordbook.sClassID = sClassID
    FrmWordbook.lHwnd = TxtObjhwnd
    Set FrmWordbook.cnn = ActiveConnection
    FrmWordbook.Show 1
    Wordbook = FrmWordbook.sWord
    Set FrmWordbook = Nothing


End If

End Function