database.cls

OA编程 源代码

On Error GoTo ErrorHandler
    Set DAOConnection = dbtDAOConnect
    Exit Property
ErrorHandler:
    'Call gclsMessage.DisplayMessage(Err.Number, , App.EXEName & " : " & "DataAccess : DAOConnection")
End Property

Public Property Get RDOConnection() As RDOConnection
On Error GoTo ErrorHandler
    Set RDOConnection = dbtRDOConnect
    Exit Property
ErrorHandler:
    'Call gclsMessage.DisplayMessage(Err.Number, , App.EXEName & " : " & "DataAccess : RDOConnection")
End Property

Public Function DAOUpdate(strUpdate As String) As Long
On Error GoTo ErrorHandler
    DAOUpdate = DAOActionQuery(strUpdate)
    Exit Function
ErrorHandler:
    'Call gclsMessage.DisplayMessage(Err.Number, , App.EXEName & " : " & "DataAccess : DAOUpdate")
End Function

Public Function DAOSelect(strSelect As String) As Recordset
On Error GoTo ErrorHandler
    If (eumDatabaseEngine = eDAO) Then
        Set DAOSelect = dbtDAOConnect.OpenRecordset(strSelect, dbOpenSnapshot)
    Else
        'Call gclsMessage.DisplayMessage(9000, "No DAO database connection exists.", App.EXEName & " : " & "DataAccess : DAOSelect")
    End If
    Exit Function
ErrorHandler:
    'Call gclsMessage.DisplayMessage(Err.Number, , App.EXEName & " : " & "DataAccess : DAOSelect")
End Function

Public Function DAOInsert(strInsert As String) As Long
On Error GoTo ErrorHandler
    DAOInsert = DAOActionQuery(strInsert)
    Exit Function
ErrorHandler:
    'Call gclsMessage.DisplayMessage(Err.Number, , App.EXEName & " : " & "DataAccess : DAOInsert")
End Function

Private Function DAOActionQuery(strAction As String) As Long
On Error GoTo ErrorHandler
    If (eumDatabaseEngine = eDAO) Then
        dbtDAOConnect.Execute strUpdate, dbExecDirect
        DAOActionQuery = dbtDAOConnect.RecordsAffected
    Else
        'Call gclsMessage.DisplayMessage(9000, "No DAO database connection exists", App.EXEName & " : " & "DataAccess : DAOActionQuery")
    End If
    Exit Function
ErrorHandler:
    'Call gclsMessage.DisplayMessage(Err.Number, , App.EXEName & " : " & "DataAccess : DAOActionQuery")
End Function

Public Function DAODelete(strDelete As String) As Long
On Error GoTo ErrorHandler
    DAODelete = DAOActionQuery(strDelete)
    Exit Function
ErrorHandler:
    'Call gclsMessage.DisplayMessage(Err.Number, , App.EXEName & " : " & "DataAccess : DAODelete")
End Function

Public Function RDOActionQuery(strAction As String) As Long
On Error GoTo ErrorHandler
    If Not (flgTransaction) Then
        If (eumDatabaseEngine = eRDO) Then
            dbtRDOConnect.Execute strAction, rdExecDirect
            RDOActionQuery = dbtRDOConnect.RowsAffected
        Else
            'Call gclsMessage.DisplayMessage(9000, "No RDO database connection exist", App.EXEName & " : " & "DataAccess : RDOActionQuery")
        End If
    Else
        RDOActionQuery = RDOActionTrans(strAction)
    End If
    Exit Function
ErrorHandler:
    'Call gclsMessage.DisplayMessage(Err.Number, , App.EXEName & " : " & "DataAccess : RDOActionQuery")
End Function

Private Function RDOActionTrans(strAction As String) As Long
On Error GoTo ErrorHandler
    Dim qyTemp As New rdoQuery

    If flgTransaction = True Then
        If gclsDatabase.DatabaseEngine = eRDO Then
            qyTemp.Sql = strAction
            qyTemp.Prepared = False
            Set qyTemp.ActiveConnection = dbtRDOConnect
            qyTemp.Execute
            RDOActionTrans = qyTemp.RowsAffected
            qyTemp.Close
        Else
            RDOActionTrans = -1
            'Call gclsMessage.DisplayMessage(9000, "No RDO database connection exist", App.EXEName & " : " & "DataAccess : RDOActionTrans")
        End If
    Else
        RDOActionTrans = -1
        'Call gclsMessage.DisplayMessage(9000, "No RDO transaction exists", App.EXEName & " : " & "DataAccess : RDOActionTrans")
    End If
    Exit Function
ErrorHandler:
    'Call gclsMessage.DisplayMessage(Err.Number, , App.EXEName & " : " & "DataAccess : RDOActionTrans")
End Function

Public Function RDOUpdateTrans(strUpdate As String) As Long
On Error GoTo ErrorHandler
    RDOUpdateTrans = RDOActionTrans(strUpdate)
    Exit Function
ErrorHandler:
    'Call gclsMessage.DisplayMessage(Err.Number, , App.EXEName & " : " & "DataAccess : RDOUpdateTrans")
End Function

Public Function RDOInsertTrans(strInsert As String) As Long
On Error GoTo ErrorHandler
    RDOInsertTrans = RDOActionTrans(strInsert)
    Exit Function
ErrorHandler:
    'Call gclsMessage.DisplayMessage(Err.Number, , App.EXEName & " : " & "DataAccess : RDOInsertTrans")
End Function

Public Function RDODeleteTrans(strDelete As String) As Long
On Error GoTo ErrorHandler
    RDODeleteTrans = RDOActionTrans(strDelete)
    Exit Function
ErrorHandler:
    'Call gclsMessage.DisplayMessage(Err.Number, , App.EXEName & " : " & "DataAccess : RDODeleteTrans")
End Function

Public Function RDOUpdate(strUpdate As String) As Long
On Error GoTo ErrorHandler
    RDOUpdate = RDOActionQuery(strUpdate)
    Exit Function
ErrorHandler:
    'Call gclsMessage.DisplayMessage(Err.Number, , App.EXEName & " : " & "DataAccess : RDOUpdate")
End Function

Public Function RDOInsert(strInsert As String) As Long
On Error GoTo ErrorHandler
    RDOInsert = RDOActionQuery(strInsert)
    Exit Function
ErrorHandler:
    'Call gclsMessage.DisplayMessage(Err.Number, , App.EXEName & " : " & "DataAccess : RDOInsert")
End Function

Public Function RDODelete(strDelete As String) As Long
On Error GoTo ErrorHandler
    RDODelete = RDOActionQuery(strDelete)
    Exit Function
ErrorHandler:
    'Call gclsMessage.DisplayMessage(Err.Number, , App.EXEName & " : " & "DataAccess : RDODelete")
End Function

Public Function RDOSelect(strSelect As String) As rdoResultset
On Error GoTo ErrorHandler
    If (eumDatabaseEngine = eRDO) Then
        Set RDOSelect = dbtRDOConnect.OpenResultset(strSelect, rdOpenStatic)
    Else
        'Call gclsMessage.DisplayMessage(9000, "No RDO database access connection exists", App.EXEName & " : " & "DataAccess : RDOSelect")
    End If
    Exit Function
ErrorHandler:
    'Call gclsMessage.DisplayMessage(Err.Number, , App.EXEName & " : " & "DataAccess : RDOSelect")
End Function

Public Function RDOSPResultset(strSPName As String, ParamArray varInputParam()) As rdoResultset
On Error GoTo ErrorHandler
    Dim qy As rdoQuery, qy1 As rdoQuery
    Dim strProcedure As String
    Dim element As Variant
    Dim intTemp As Integer
    Dim rs As rdoResultset

    For Each qy In RDOConnection.rdoQueries
        If qy.Name = "STOREDPROC" Then
            qy.Close
        End If
    Next qy

    strProcedure = "{? = CALL " & strSPName
    intTemp = 0
    For Each element In varInputParam
        If intTemp = 0 Then
            strProcedure = strProcedure & "("
        End If
        strProcedure = strProcedure & " ?,"
        intTemp = 1
    Next element
    If intTemp > 0 Then
        strProcedure = Left(strProcedure, Len(strProcedure) - 1)
        strProcedure = strProcedure & ")"
    End If
    strProcedure = strProcedure & " }"

    Set qy = dbtRDOConnect.CreateQuery("STOREDPROC", strProcedure)
    qy.rdoParameters(0).Direction = rdParamReturnValue
    intTemp = 1
    For Each element In varInputParam
        qy.rdoParameters(intTemp).Direction = rdParamInput
        intTemp = intTemp + 1
    Next element
        
    Set qy1 = RDOConnection.rdoQueries!STOREDPROC
    intTemp = 1
    For Each element In varInputParam
        qy1.rdoParameters(intTemp) = element
        intTemp = intTemp + 1
    Next element

    Set RDOSPResultset = qy1.OpenResultset(rdOpenStatic)

    Exit Function
ErrorHandler:
    'Call gclsMessage.DisplayMessage(Err.Number, , App.EXEName & " : DataAccess : RDOSPResultset")
End Function

Public Function RDOSPValue(strSPName As String, ParamArray varInputParam()) As Variant
On Error GoTo ErrorHandler
    Dim qy As rdoQuery, qy1 As rdoQuery
    Dim strProcedure As String
    Dim element As Variant
    Dim intTemp As Integer
    Dim rs As rdoResultset

    For Each qy In RDOConnection.rdoQueries
        If qy.Name = "STOREDPROC" Then
            qy.Close
        End If
    Next qy

    strProcedure = "{? = CALL " & strSPName
    intTemp = 0
    For Each element In varInputParam
        If intTemp = 0 Then
            strProcedure = strProcedure & "("
        End If
        strProcedure = strProcedure & " ?,"
        intTemp = 1
    Next element
    If intTemp > 0 Then
        strProcedure = Left(strProcedure, Len(strProcedure) - 1)
        strProcedure = strProcedure & ")"
    End If
    strProcedure = strProcedure & " }"

    Set qy = dbtRDOConnect.CreateQuery("STOREDPROC", strProcedure)
    qy.rdoParameters(0).Direction = rdParamReturnValue
    intTemp = 1
    For Each element In varInputParam
        qy.rdoParameters(intTemp).Direction = rdParamInput
        intTemp = intTemp + 1
    Next element
        
    Set qy1 = RDOConnection.rdoQueries!STOREDPROC
    intTemp = 1
    For Each element In varInputParam
        qy1.rdoParameters(intTemp) = element
        intTemp = intTemp + 1
    Next element

    qy1.Execute
    RDOSPValue = qy1.rdoParameters(0)

    Exit Function
ErrorHandler:
    'Call gclsMessage.DisplayMessage(Err.Number, , App.EXEName & " : DataAccess : RDOSPResultset")
End Function