VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "DBHelper"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Const m_modName As String = "FMStocks_DB.DBHelper"


Dim m_DBServer As String
Dim m_ConnectionString As String

Private Sub IObjectConstruct_Construct(ByVal pCtorObj As Object)
    'eval construction string and find out what the admin wants us to do
    Dim arrParams, x As Integer, strHints As String
    
    On Error GoTo errorHandler
    strHints = pCtorObj.ConstructString
    arrParams = Split(strHints, ",")
    For x = LBound(arrParams) To UBound(arrParams)
        Select Case UCase(GetKey(arrParams(x)))
            Case UCase("ConnectionString")
                m_ConnectionString = GetValue(arrParams(x))
            Case UCase("Server")
                m_DBServer = GetValue(arrParams(x))
        End Select
    Next
    
    Exit Sub
    
errorHandler:
    RaiseError m_modName & "(IObjectConstruct Interface)", "Construct(" & strHints & ")", bWriteToLog:=True
End Sub

Function GetConnectionString() As String
    On Error GoTo errorHandler
    
    If m_ConnectionString <> "" Then
        GetConnectionString = m_ConnectionString
    Else
        'assume that we want to use a SQL Server connection through OLDEB
        If m_DBServer <> "" Then
            GetConnectionString = "Provider=SQLOLEDB;Data Source=" & m_DBServer & ";User Id=stocks_login;Password=password;Connect Timeout=3;network library=dbmssocn;"
        Else
            'GetConnectionString = "Provider=SQLOLEDB;Data Source=localhost;User Id=stocks_login;Password=password;Connect Timeout=3;network library=dbmssocn;"
            GetConnectionString = "Provider=SQLOLEDB;Data Source=(local);User Id=stocks_login;Password=password;Connect Timeout=3;network library=dbmssocn;"
        End If
    End If
    
    Exit Function
    
errorHandler:
    RaiseError m_modName, "GetConnectionString()", bWriteToLog:=True
End Function

Function RunSPReturnRS(ByVal strSP As String, Optional params As Variant, _
                       Optional strConn As String) As ADODB.Recordset
    On Error GoTo errorHandler
    
    ' Create the ADO objects
    Dim rs As ADODB.Recordset, cmd As ADODB.Command
    Set rs = New ADODB.Recordset
    Set cmd = New ADODB.Command
    
    ' Init the ADO objects  & the stored proc parameters
    If strConn = "" Then
        cmd.ActiveConnection = GetConnectionString()
    Else
        cmd.ActiveConnection = strConn
    End If
    cmd.CommandText = strSP
    cmd.CommandType = adCmdStoredProc
    
    collectParams cmd, params
    
    ' Execute the query for readonly
    rs.CursorLocation = adUseClient
    rs.Open cmd, , adOpenStatic, adLockReadOnly
    
    ' Disconnect the recordset
    Set cmd.ActiveConnection = Nothing
    Set cmd = Nothing
    Set rs.ActiveConnection = Nothing

    ' Return the resultant recordset
    Set RunSPReturnRS = rs
    Exit Function
    
errorHandler:
    Set rs = Nothing
    Set cmd = Nothing
    RaiseError m_modName, "RunSPReturnRS(" & strSP & ", ...)"
End Function

' RunSQLReturnRS differs from RunSPReturnRS only on the line that
' sets the cmd.CommandType = adCmdText vs. adCmdStoredProc

Function RunSQLReturnRS(ByVal strSQL As String, params As Variant, Optional strConn As String) As ADODB.Recordset
    On Error GoTo errorHandler
    
    ' Set up Command and Connection objects
    Dim rs As ADODB.Recordset, cmd As ADODB.Command
    Set rs = New ADODB.Recordset
    Set cmd = New ADODB.Command

    'Run the procedure
    If strConn = "" Then
        cmd.ActiveConnection = GetConnectionString()
    Else
        cmd.ActiveConnection = strConn
    End If
    cmd.CommandText = strSQL
    cmd.CommandType = adCmdText
    
    collectParams cmd, params
    
    rs.CursorLocation = adUseClient
    rs.Open cmd, , adOpenStatic, adLockReadOnly
    
    ' Disconnect the recordsets and cleanup
    Set cmd.ActiveConnection = Nothing
    Set cmd = Nothing
    Set rs.ActiveConnection = Nothing
    
    Set RunSQLReturnRS = rs
    Exit Function
    
errorHandler:
    Set rs = Nothing
    Set cmd = Nothing
    RaiseError m_modName, "RunSQLReturnRS(" & Left(strSQL, 10) & ", ...)"
End Function

Function RunSPReturnRS_RW(ByVal strSP As String, params As Variant, Optional strConn As String) As ADODB.Recordset
    On Error GoTo errorHandler
    
    ' Create the ADO objects
    Dim rs As ADODB.Recordset, cmd As ADODB.Command
    Set rs = New ADODB.Recordset
    Set cmd = New ADODB.Command
    
    ' Init the ADO objects & the stored proc parameters
    If strConn = "" Then
        cmd.ActiveConnection = GetConnectionString()
    Else
        cmd.ActiveConnection = strConn
    End If
    cmd.CommandText = strSP
    cmd.CommandType = adCmdStoredProc
    collectParams cmd, params
    rs.CursorLocation = adUseClient
    
    ' Execute the query as an updatable recordset and stay connected
    rs.Open cmd, , adOpenDynamic, adLockBatchOptimistic
    Set cmd = Nothing
    
    ' Return and quit
    Set RunSPReturnRS_RW = rs
    Exit Function
    
errorHandler:
    Set rs = Nothing
    Set cmd = Nothing
    RaiseError m_modName, "RunSPReturnRS_RW(" & strSP & ", ...)"
End Function

Function RunSQLReturnRS_RW(ByVal strSQL As String, params As Variant, Optional strConn As String) As ADODB.Recordset
    On Error GoTo errorHandler
    
    ' Create the ADO objects
    Dim rs As ADODB.Recordset, cmd As ADODB.Command
    Set rs = New ADODB.Recordset
    Set cmd = New ADODB.Command
       
    ' Init the ADO objects & the stored proc parameters
    If strConn = "" Then
        cmd.ActiveConnection = GetConnectionString()
    Else
        cmd.ActiveConnection = strConn
    End If
    cmd.CommandText = strSQL
    cmd.CommandType = adCmdText
    collectParams cmd, params
    rs.CursorLocation = adUseClient
    
    ' Execute the query as an updatable recordset and stay connected
    rs.Open cmd, , adOpenDynamic, adLockBatchOptimistic
    Set cmd = Nothing
    
    ' Return and quit
    Set RunSQLReturnRS_RW = rs
    Exit Function
    
errorHandler:
    Set rs = Nothing
    Set cmd = Nothing
    RaiseError m_modName, "RunSQLReturnRS_RW(" & strSQL & ", ...)"
End Function

Function RunSP(ByVal strSP As String, params As Variant, Optional strConn As String)
    On Error GoTo errorHandler
    
    ' Create the ADO objects
    Dim cmd As ADODB.Command
    Set cmd = New ADODB.Command
    
    ' Init the ADO objects & the stored proc parameters
    If strConn = "" Then
        cmd.ActiveConnection = GetConnectionString()
    Else
        cmd.ActiveConnection = strConn
    End If
    cmd.CommandText = strSP
    cmd.CommandType = adCmdStoredProc
    collectParams cmd, params
    
    ' Execute the query without returning a recordset
    cmd.Execute , , adExecuteNoRecords
    
    ' Disconnect the command and clean up
    Set cmd.ActiveConnection = Nothing
    Set cmd = Nothing
    
    Exit Function
    
errorHandler:
    Set cmd = Nothing
    RaiseError m_modName, "RunSP(" & strSP & ", ...)"
End Function

Function RunSQL(ByVal strSQL As String, params As Variant, Optional strConn As String)
    On Error GoTo errorHandler
    
    ' Create the ADO objects
    Dim cmd As ADODB.Command
    Set cmd = New ADODB.Command

    ' Init the ADO objects & the stored proc parameters
    If strConn = "" Then
        cmd.ActiveConnection = GetConnectionString()
    Else
        cmd.ActiveConnection = strConn
    End If
    cmd.CommandText = strSQL
    cmd.CommandType = adCmdText
    collectParams cmd, params
    
    ' Execute the query without returning a recordset
    cmd.Execute , , adExecuteNoRecords
    
    ' Cleanup
    Set cmd.ActiveConnection = Nothing
    Set cmd = Nothing
    
    Exit Function
    
errorHandler:
    Set cmd = Nothing
    RaiseError m_modName, "RunSQL(" & Left(strSQL, 10) & ", ...)"
End Function

Function RunSPReturnInteger(ByVal strSP As String, params As Variant, Optional strConn As String) As Long 'adInterger is really a VB Long
    On Error GoTo errorHandler
    
    ' Create the ADO objects
    Dim cmd As ADODB.Command
    Set cmd = New ADODB.Command
    
    ' Init the ADO objects & the stored proc parameters
    If strConn = "" Then
        cmd.ActiveConnection = GetConnectionString()
    Else
        cmd.ActiveConnection = strConn
    End If
    cmd.CommandText = strSP
    cmd.CommandType = adCmdStoredProc
    collectParams cmd, params
    
    ' Assume the last parameter is outgoing
    cmd.Parameters.Append cmd.CreateParameter("@retval", adInteger, adParamOutput, 4)
    
    ' Execute without a resulting recordset and pull out the "return value" parameter
    cmd.Execute , , adExecuteNoRecords
    RunSPReturnInteger = cmd.Parameters("@retval").Value
    
    ' Disconnect the command, and clean up
    Set cmd.ActiveConnection = Nothing
    Set cmd = Nothing
    
    Exit Function
    
errorHandler:
    Set cmd = Nothing
    RaiseError m_modName, "RunSPReturnInteger(" & strSP & ", ...)"
End Function

Function RunSQLReturnInteger(ByVal strSQL As String, params As Variant, Optional strConn As String) As Long 'adInterger is really a VB Long
    On Error GoTo errorHandler
    
    ' Create the ADO objects
    Dim cmd As ADODB.Command
    Set cmd = New ADODB.Command
    
    ' Init the ADO objects & the stored proc parameters
    If strConn = "" Then
        cmd.ActiveConnection = GetConnectionString()
    Else
        cmd.ActiveConnection = strConn
    End If
    cmd.CommandText = strSQL
    cmd.CommandType = adCmdText
    
    ' Assume the first parameter is outgoing
    cmd.Parameters.Append cmd.CreateParameter("@retval", adInteger, adParamOutput, 4)
    
    collectParams cmd, params
    
    
    ' Execute without a resulting recordset and pull out the "return value" parameter
    cmd.Execute , , adExecuteNoRecords
    RunSQLReturnInteger = cmd.Parameters("@retval").Value
    
    ' Disconnect the command, and clean up
    Set cmd.ActiveConnection = Nothing
    Set cmd = Nothing
    
    Exit Function
    
errorHandler:
    Set cmd = Nothing
    RaiseError m_modName, "RunSQLReturnInteger(" & Left(strSQL, 10) & ", ...)"
End Function

Private Sub collectParams(ByRef cmd As ADODB.Command, ByVal argparams As Variant)
    Dim params As Variant, v As Variant
    Dim i As Integer, l As Integer, u As Integer
    'if argparams is empty
    
    If Not IsArray(argparams) Then Exit Sub
    
    params = argparams
    For i = LBound(params) To UBound(params)
        l = LBound(params(i))
        u = UBound(params(i))
        ' Check for nulls.
        If u - l = 3 Then
            If VarType(params(i)(3)) = vbString Then
                v = IIf(params(i)(3) = "", Null, params(i)(3))
            Else
                v = params(i)(3)
            End If
            cmd.Parameters.Append cmd.CreateParameter(params(i)(0), params(i)(1), adParamInput, params(i)(2), v)
        Else
            RaiseError m_modName, "collectParams(...): incorrect # of parameters", bWriteToLog:=True
        End If
    Next i
End Sub

Private Sub Class_Initialize()
    m_DBServer = GetComputerName
    ' to simplify the demo, I will assume the SQL server is accessible through the local machine name
End Sub
