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

Private adoConnection As ADODB.Connection
Private bolIsOpen As Boolean

Public Sub ConnectToDB(ByRef strDSN As String, ByRef strUID As String, ByRef strPWD As String)

On Error GoTo ConnectToDBErr
    
    Dim strConnectString As String
    
    Set adoConnection = New ADODB.Connection
    
    strConnectString = "uid=" & strUID & ";pwd=" & strPWD & ";dsn=" & strDSN
'    strConnectString = "User ID=" & strUID & ";Password=" & strPWD & ";Data Source=10.149.2.24;DSN=OracleIVRDSN"
'    adoConnection.Provider = "MSDAORA"
    
    ' Establish a connection to the database
    adoConnection.ConnectionString = strConnectString
    
    adoConnection.Open
    
    ' The Database connection was opened successfully
    IsOpen = True
    
ConnectToDBExit:
    Exit Sub

ConnectToDBErr:
    On Error Resume Next
    ' Remove the Connection Object
    Set adoConnection = Nothing
    
    ' The Database connection was not opened
    IsOpen = False
    
'    Err.Raise 1008, "clsDatabaseAccess", "Could not connect to the database. No files will be processed."
    addLogEntry (Err.Number + " -  " + Err.Description)
    
    Err.Raise Err.Number, Err.Source, Err.Description
    Resume ConnectToDBExit
    
End Sub

Public Sub CloseConnection()

On Error GoTo CloseConnectionErr

    adoConnection.Close

CloseConnectionExit:
    Exit Sub
    
CloseConnectionErr:
    On Error Resume Next
    ' Remove the Connection Object
    Set adoConnection = Nothing
    
'    Err.Raise 1008, "clsDatabaseAccess", "Could not disconnect from the database"
    addLogEntry (Err.Number + " -  " + Err.Description)
    Err.Raise Err.Number, Err.Source, Err.Description
    Resume CloseConnectionExit
    
End Sub

Public Sub InsertData(ByRef colData As Collection)

On Error GoTo InsertDataErr

    Dim strSql As String
    Dim adoCommand As ADODB.Command
    Dim intField As Integer
    Dim lngNumOfRecs As Long
    
    ' Set up the sql string for execution
    ' The collection 'colData' contains the fields
    ' and their values for insertion. They are grouped
    ' as follows: colData(1) = field, colData(2) = value, etc.
    ' The first entry is the table name we must insert the
    ' data into. The fields and their values follow the table name.
    
    strSql = "insert into " & colData(1) & " ("
    
    ' Add all the fields that must be added
    ' They are in positions 2,4,6,8, etc.
    For intField = 2 To colData.Count Step 2
        strSql = strSql & colData(intField) & ","
    Next intField
    
    ' Cut off the last ',' that was added
    strSql = Left$(strSql, Len(strSql) - 1)
    
    strSql = strSql & ") values ('"
    
    ' Add the values for the fields to insert
    ' They are in positions 3,5,7,9,etc.
    For intField = 3 To colData.Count Step 2
        ' Convert dates
        If IsDate(colData(intField)) Then
            strSql = Left$(strSql, Len(strSql) - 1) & _
                        "TO_DATE('" & colData(intField) & _
                        "','DD MON YYYY HH24:MI'),'"
        Else
            strSql = strSql & colData(intField) & "','"
        End If
        
    Next intField
    
    ' Strip off the last ",'" that was added
    strSql = Left$(strSql, Len(strSql) - 2)
    
    strSql = strSql & ")"
    
    Set adoCommand = New ADODB.Command
   
' Only used for testing
'adoConnection.Close

    ' Get the current database connection
    adoCommand.ActiveConnection = adoConnection
    
    ' Assign the SQL string to the command object
    adoCommand.CommandText = strSql
    
    ' Set the command type to command text
    adoCommand.CommandType = adCmdText
    
    ' Insert the data and get the number of affected records
    adoCommand.Execute lngNumOfRecs
    
    ' If no records were inserted, then we must write
    ' the SQL out to a file for later processing
    If lngNumOfRecs = 0 Then
        Err.Raise vbObjectError + 1009, "clsDatabaseAccess", "No records were inserted"
    End If
    
    Set adoCommand = Nothing
    
InsertDataExit:
    Exit Sub
    
InsertDataErr:
    On Error Resume Next
    'Remove the Command Object
    Set adoCommand = Nothing
    
    Dim lngErrNum As Long
    lngErrNum = Err.Number
'    If Err.Number = -2147217900 Then    ' Duplicate values
    If lngErrNum = -2147217900 Then    ' Duplicate values
        Err.Raise lngErrNum, "clsDatabaseAccess", "The value being inserted already exists in the database"
'        Err.Clear
'        Resume Next
    Else
'        Err.Raise 1009, "clsDatabaseAccess", strSQL
        
        addLogEntry (Err.Number + " -  " + Err.Description)
        Err.Raise Err.Number, Err.Source, Err.Description
    End If

    Resume InsertDataExit
    
End Sub

Public Sub UpdateData(ByRef colData As Collection, ByRef intNumOfKeys As Integer)
    
On Error GoTo UpdateDataErr

    Dim strSql As String
    Dim adoCommand As ADODB.Command
    Dim intField As Integer
    Dim lngNumOfRecs As Long
    Dim intStart As Integer
    Dim intKey As Integer
    
    ' Set up the sql string for execution
    ' The collection 'colData' contains the fields
    ' and their values for updating. They are grouped
    ' as follows: colData(1) = field, colData(2) = value, etc.
    ' The first entry is the table name we must update.
    ' The variable intNumOfKeys indicate how many key
    ' fields we must use in the where clause. The key
    ' fields follow the table name to update.
    
    strSql = "update " & colData(1)
    strSql = strSql & " set "
    
    ' Determine where the fields start
    intStart = (intNumOfKeys + 1) * 2
    
    ' Add all the fields that must be updated
    ' They are in positions 6,8,10, etc.
    ' The values are in position 7,9,11, etc.
    For intField = intStart To colData.Count - 1 Step 2
        ' Test for dates
        If IsDate(colData(intField + 1)) Then
            strSql = strSql & colData(intField) & "=" & _
                        "TO_DATE('" & colData(intField + 1) & _
                        "','DD MON YYYY HH24:MI:SS'),"
        Else
            strSql = strSql & colData(intField) & "='" & _
                        colData(intField + 1) & "',"
        End If
    Next intField
    
    ' Cut off the last ',' that was added
    strSql = Left$(strSql, Len(strSql) - 1)
    
    ' Add the key fields into the where clause
'        strSQL = strSQL & " where " & colData(2) & _
'                    "='" & colData(3) & "' and " & _
'                    colData(4) & "='" & colData(5) & "'"
    intStart = intStart - 1
    strSql = strSql & " where "
    For intKey = 2 To intStart Step 2
        strSql = strSql & colData(intKey) & _
                    "='" & colData(intKey + 1) & "' and "
    Next intKey
    
    ' Remove the last `and` from the SQL string
    strSql = Left$(strSql, Len(strSql) - 5)
    
    Set adoCommand = New ADODB.Command
    
    ' Get the current database connection
    adoCommand.ActiveConnection = adoConnection
    
    ' Assign the SQL string to the command object
    adoCommand.CommandText = strSql
    
    ' Set the command type to command text
    adoCommand.CommandType = adCmdText
    
    ' Update the data and get the number of affected records
    adoCommand.Execute lngNumOfRecs

    ' If no records were updated, then we must write
    ' the SQL out to a file for later processing
    If lngNumOfRecs = 0 Then
'        Err.Raise  1007, "clsDatabaseAccess", strSQL
        Dim strErr As String
        For intKey = 2 To intStart Step 2
            strErr = strErr & colData(intKey) & _
                        ": " & colData(intKey + 1) & ", "
        Next intKey
    
        ' Remove the last `, ` from the SQL string
        strErr = Left$(strErr, Len(strErr) - 2)

        Err.Raise vbObjectError + 1007, "clsDatabaseAccess", "No records were updated - " & strErr
    End If
    
    Set adoCommand = Nothing
    
UpdateDataExit:
    Exit Sub
    
UpdateDataErr:
    On Error Resume Next
    ' Remove the Command Object
    Set adoCommand = Nothing
    
'    Err.Raise 1007, "clsDatabaseAccess", "Could not update the Database"
'    Err.Raise 1007, "clsDatabaseAccess", strSQL
    addLogEntry (Err.Number + " -  " + Err.Description + " - " + strSql)
    Err.Raise Err.Number, Err.Source, Err.Description
    Resume UpdateDataExit
    
End Sub

Public Sub ExecuteSQL(ByRef strSql As String, Optional rsAdoRecordset As ADODB.Recordset)
    On Error GoTo Err_ExecuteSQL
    
    Dim adoCommand As ADODB.Command
    Dim lngNumOfRecs As Long
    Dim bolRecordsetOpen As Boolean

    ' Set the flag to False
    bolRecordsetOpen = False
    
    ' Create a command object
    Set adoCommand = New ADODB.Command

    ' Get the current database connection
    adoCommand.ActiveConnection = adoConnection
    
    ' Assign the SQL string to the command object
    adoCommand.CommandText = strSql

    ' Set the command type to command text
    adoCommand.CommandType = adCmdText

    ' Test to see if we must return a recordset to the caller
    If IsNull(rsAdoRecordset) = True Then
        ' Update the data and get the number of affected records
        adoCommand.Execute lngNumOfRecs
    
        ' If no records were updated, then we must write
        ' the SQL out to a file for later processing
        If lngNumOfRecs = 0 Then
'            Err.Raise 1007, "clsDatabaseAccess", strSQL
            Err.Raise vbObjectError + 1007, "clsDatabaseAccess", "No records updated/deleted/inserted"
        End If
    Else
        ' Return the recordset to the caller
'        rsAdoRecordset.CursorType = adOpenKeyset
'        rsAdoRecordset.CursorLocation = adUseServer
        Set rsAdoRecordset = adoCommand.Execute(lngNumOfRecs)
        
        ' We have successfully opened the recordset
        bolRecordsetOpen = True
        
'        rsAdoRecordset.Open strSQL, adoConnection, adOpenKeyset, adLockOptimistic, adCmdText

        
        ' If no records were retrieved, then we must raise
        ' an error
        If lngNumOfRecs = 0 Then
'            Err.Raise 1007, "clsDatabaseAccess", "No records found."
            Err.Raise vbObjectError + 1007, "clsDatabaseAccess", "No records found"
        End If
    End If
    
    ' Remove the command object
    Set adoCommand = Nothing
    
Exit_Err_ExecuteSQL:
    Exit Sub
    
Err_ExecuteSQL:
    On Error Resume Next
    
    ' Remove the Command Object
    Set adoCommand = Nothing
    
    ' Remove the Resultset
    If bolRecordsetOpen Then
        rsAdoRecordset.Close
    End If
    Set rsAdoRecordset = Nothing
        ' Pass the error up to ProcessDirectoryOne
    With Err
         addLogEntry (Err.Number & " -  " + Err.Description)
        .Raise .Number, .Source, .Description
    End With
    
    Resume Exit_Err_ExecuteSQL
    
End Sub

Private Sub Class_Terminate()
    On Error Resume Next
    
    ' Remove the Connection Object
    Set adoConnection = Nothing
    
End Sub

Public Property Get IsOpen() As Variant
    IsOpen = bolIsOpen
End Property

Private Property Let IsOpen(ByVal vNewValue As Variant)
    bolIsOpen = True
End Property

Public Sub addLogEntry(ByRef errormsg As String)
   Dim strLogMsg As String
   ' Create the log message for the number of updates
        strLogMsg = vbNullString
        strLogMsg = Format$(Now, "yyyy-mm-dd Hh:Nn:Ss") & _
                    "        DB Error " & _
                    errormsg
                    
            
        ' Add a log entry
        frmLog.addLogEntry strLogMsg
        
End Sub