How to efficiently check if ADODB.Connection is really open

[OldClock]

Hey

I have indeed found a good solution. I know it's good because I have put it through many tests and found no wasted overhead, and also because it's been running for a few years on many networks in a few African countries where the power goes out on a daily basis, problems would have been caught when the power goes back on.

The important part is this: you instantiate a new connection on program startup, the connection is closed and reopened after each query, but it must not be destroyed throughout the program's session. Opening and closing it does not cause wasted overhead, but destroying it and instantiating a new one would.

I will provide a (mostly-)complete code example, as it took years of experimentation to reach this stable point.

Declare this somewhere persistent throughought your program's life, e.g. in your loader module:

Public g_mhD As MariaHandler

In your program's startup:

Set g_mhD = New MariaHandler
    If Not g_mhD.Init Then
        Call MsgBox("Opening a connection to the database failed." & App.ProductName & ".", vbCritical, App.Title)
        Exit Sub
    End If

Now in the MariaHandler class:

' If compiling in Win7 there is a risk that the binary won't run in Vista/XP
' See this article for the resolution:
' [url]https://support.microsoft.com/en-us/help/2517589/an-ado-application-does-not-run-on-down-level-operating-systems-after[/url]
 
Private m_cn As ADODB.Connection
Private m_rs As ADODB.Recordset
Private m_cmd As ADODB.Command
 
Public Function Init() As Boolean
    Dim success As Boolean
    success = initConn
    Init = success
End Function
 
' Instantiate and test new connection.
Private Function initConn() As Boolean
    Dim connStr As String
    Dim success As Boolean
 
    On Error GoTo Fail
 
    success = False
 
    Set m_cn = New ADODB.Connection
 
    ' Configure connection
    connStr = g_cfgD.dbConnDriver _
        & ";SERVER=" & g_cfgD.dbServer _
        & ";DATABASE=" & g_cfgD.dbName _
        & ";UID=" & g_cfgD.dbUser _
        & ";PWD=" & g_cfgD.dbPwd _
        & ";PORT=" & g_cfgD.dbPort _
        & ";POOLING=true" _
        & ";OPTION=3"
 
    m_cn.ConnectionString = connStr
    m_cn.CommandTimeout = 30
 
    ' Test that the connection works
    success = openConn
 
    Call closeConn
 
    initConn = success
    Exit Function
 
Fail:
    initConn = False
    Call failHandler("initConn", "", err, "Initializing a connection to the database failed!")
End Function
 
Private Function openConn() As Boolean
    On Error GoTo Fail
 
    If m_cn.State <> adStateOpen Then
        ' An error is raised here if any of the details in m_cn.ConnectionString are wrong
        Call m_cn.Open
    End If
 
    If m_cn.State = adStateOpen Then
        openConn = True
    Else
        openConn = False
    End If
 
    Exit Function
 
Fail:
    openConn = False
    Call failHandler("openConn", "", err, "Opening a connection to the database failed!")
End Function
 
Public Sub destroyConn()
    On Error Resume Next
 
    Set m_cmd.ActiveConnection = Nothing
    Call m_rs.Close
    Set m_rs.ActiveConnection = Nothing
    Call m_cn.Close
 
    Set m_cmd = Nothing
    Set m_rs = Nothing
End Sub
 
Public Sub closeConn()
    ' [url]https://docs.microsoft.com/en-us/sql/ado/reference/ado-api/close-method-ado[/url]
    ' [url]https://msdn.microsoft.com/en-us/library/ms810829.aspx[/url]
    ' [url]https://mysql-net.github.io/MySqlConnector/connection-options/[/url]
    ' Note: you cannot access m_rs once m_cn.Close is called
    If m_cn.State <> adStateClosed Then
        Call m_cn.Close
    End If
End Sub
 
' Called after every query is executed and m_rs no longer needed
Private Sub rsCleanup()
    Call closeConn
 
    If Not m_rs Is Nothing Then
        If m_rs.State <> adStateClosed Then ' Closed when executing an INSERT or UPDATE, open on SELECT
            Call m_rs.Close
        End If
        Set m_rs = Nothing
    End If
 
    Set m_cmd = Nothing
End Sub
 
' Executes a given query and sets the modular m_rs object
Private Function executeQuery(ByVal sqlQuery As String, ByVal callerName As String)
    On Error GoTo Fail
 
    Call executeCommand(sqlQuery)
 
    Exit Function
 
Fail:
    ' The error is re-raised for the calling function to handle.
    err.Raise err.number, err.Source, err.description, err.HelpFile, err.HelpContext
End Function
 
' Tries to execute ADODB.Command.
Private Function executeCommand(ByVal sqlQuery As String) As Boolean
    Dim recordsAffected As Long
    Dim success As Boolean
 
    success = False
    On Error GoTo Fail
 
    If Not m_cn Is Nothing Then
 
        ' Parameterized queries require an ad-hoc m_cmd, which must be destroyed once used
        ' so that the next query does not encounter old parameters. m_cmd is destroyed at
        ' the end of this function. Non-parameterized queries do not instantiate a new m_cmd,
        ' so that is done here:
        If m_cmd Is Nothing Then ' Non-parameterized query
            Set m_cmd = New ADODB.Command
            m_cmd.CommandType = adCmdText
        End If
 
        If Not m_cmd Is Nothing Then
            If openConn Then
                m_cmd.ActiveConnection = m_cn
                m_cmd.CommandText = sqlQuery
                Set m_rs = m_cmd.Execute(recordsAffected)
                success = True
                ' Do not close connection or destroy m_cmd yet as that would prevent access
                ' to m_rs, needed not only for SELECT statements but also for retrieving
                ' error number from stored procedures.
            End If
        End If
    End If
 
    executeCommand = success
    Exit Function
 
Fail:
    err.Raise err.number, err.Source, err.description, err.HelpFile, err.HelpContext
End Function
 
Private Sub Class_Terminate()
    Call destroyConn
End Sub
 
' Optional, makes error messages more human-friendly
Private Sub failHandler( _
    ByVal procName As String, _
    ByVal queryStr As String, _
    ByVal err As ErrObject, _
    Optional ByVal leadDesc As String)
 
    Dim desc As String
    Dim descPrefix As String
    Dim errDscr As String
    Dim errNbr As Long
    Dim errSrc As String
    Dim ll As Long
    Dim p As Parameter
    Dim msg As String
    Dim regex As RegExp
    Dim res As Integer
 
    ' Handle errors in this error handler.
    ' "On Error..." resets the ErrObject, so backup the error info first:
    errDscr = err.description
    errNbr = err.number
    errSrc = err.Source
    On Error Resume Next
 
    Set regex = New RegExp
 
    If procName = "openConn" Then
        ' m_cn.Open failed, precise cause is in errDscr
        ' e.g.
        ' [MySQL][ODBC 5.3(w) Driver]Access denied for user 'foo'@'localhost' (using password: YES)
 
        regex.Pattern = "\]([^\]]+)$" ' Match last ']'
        descPrefix = regex.Replace(errDscr, "]")
 
        regex.Pattern = ".*\]([^\]]+)$" ' Match everything after last ']'
        desc = regex.Replace(errDscr, "$1")
 
        msg = "Opening a connecton to the database failed:" & vbNewLine _
            & desc & vbNewLine _
            & vbNewLine _
            & "Check the database connection settings in" & vbNewLine _
            & Environ("ALLUSERSPROFILE") & "" & App.ProductName & ".ini" & vbNewLine _
            & vbNewLine _
            & "Error number: " & errNbr & vbNewLine _
            & "Source: " & descPrefix & vbNewLine _
            & "Source: " & errSrc & vbNewLine _
            & "Procedure: " & procName
 
    Else
 
        ' Split errDscr to make it more readable and to make the dialog less wide
        regex.Pattern = "\]([^\]]+)$" ' Match last ']'
        desc = regex.Replace(errDscr, "]" & vbNewLine & "$1")
 
        If LenB(leadDesc) = 0 Then
            msg = "There was an error while communicating with the database." & vbNewLine & vbNewLine
        Else
            msg = leadDesc & vbNewLine & vbNewLine
        End If
 
        msg = msg & "Error number: " & errNbr & vbNewLine _
            & "Source: " & errSrc & vbNewLine _
            & "Procedure: " & procName & vbNewLine _
            & vbNewLine _
            & "Description: " & vbNewLine _
            & desc & vbNewLine
 
        If LenB(queryStr) > 0 Then
            ' Replace ? with parameters
            If Not m_cmd Is Nothing Then
                If m_cmd.Parameters.Count > 0 Then
                    For ll = 1 To m_cmd.Parameters.Count
                        Set p = m_cmd.Parameters(ll - 1)
                        queryStr = Replace(queryStr, "?", "'" & p.Value & "'", 1, ll)
                    Next
                End If
            End If
            msg = msg & vbNewLine & queryStr
        End If
 
    End If
 
    Debug.Print msg
    Call MsgBox(msg, vbExclamation, App.Title)
 
    Set m_cmd = Nothing
 
    res = MsgBox("Would you like to close " & App.ProductName & "?" & vbNewLine & _
        "Press ""Yes"" to close it ""No"" to continue using it.", vbQuestion + vbYesNo + vbDefaultButton2, App.Title)
 
    If res = vbYes Then
        Call destroyConn
        Call unloadForms
        End
    End If
End Sub

Helper utils:

Public Const MYSQL_DATETIME_LENGTH As Integer = 19 ' "yyyy-mm-dd hh:mm:ss"
Public Const MYSQL_DATETIME_FORMAT As String = "yyyy-mm-dd hh:mm:ss"
Public Const MYSQL_DATE_LENGTH As Integer = 10 ' "yyyy-mm-dd"
Public Const MYSQL_DATE_FORMAT As String = "yyyy-mm-dd"
 
Public Function getMysqlDate(ByVal v As Variant, doIncludeTime As Boolean) As String
    Dim str As String
 
    If v = 0 Then
        ' Format$(0, MYSQL_DATETIME_FORMAT) returns 1899-12-30 00:00:00
        If doIncludeTime Then
            str = "0000-00-00 00:00:00"
        Else
            str = "0000-00-00"
        End If
    Else
        If doIncludeTime Then
            str = Format$(v, MYSQL_DATETIME_FORMAT)
        Else
            str = Format$(v, MYSQL_DATE_FORMAT)
        End If
    End If
 
    getMysqlDate = str
End Function
 
Public Function getDateTimeNull(ByVal v As Variant) As Date
    If IsDate(v) Then
        getDateTimeNull = v
    Else
        getDateTimeNull = 0
    End If
End Function

And finally, example functions for storing and selecting data, using parameterized queries:

' The id is set by MariaDB:
'   `id` BIGINT UNSIGNED NOT NULL AUTO_INCREMENT
'   PRIMARY KEY (`id`)
' It is then retrieved after the insert, so that your program can refer to fooD.id
Public Function storeFooData(ByVal fooD As FooData) As Boolean
    Dim queryStr As String
 
    On Error GoTo Fail
 
    queryStr = "INSERT INTO foo (" _
        & "item_name, " _
        & "expiry, " _
        & "stock, " _
        & "is_deleted)" & vbNewLine _
        & "VALUES (?, ?, ?, ?);"
 
    Set m_cmd = New ADODB.Command
    m_cmd.Parameters.Append m_cmd.CreateParameter(, adVarWChar, adParamInput, 100, fooD.name)
    m_cmd.Parameters.Append m_cmd.CreateParameter(, adVarChar, adParamInput, MYSQL_DATE_LENGTH, getMysqlDate(fooD.expiry, False)) ' Gotcha
    m_cmd.Parameters.Append m_cmd.CreateParameter(, adUnsignedInt, adParamInput, 10, fooD.stock)
    m_cmd.Parameters.Append m_cmd.CreateParameter(, adBoolean, adParamInput, 1, fooD.isDeleted)
 
    Call executeQuery(queryStr, "storeFooData")
    Call executeQuery("SELECT LAST_INSERT_ID();", "storeFooData")
    If Not m_rs Is Nothing Then
        If Not m_rs.EOF Then
            fooD.id = m_rs("LAST_INSERT_ID()")
        End If
    End If
 
    storeFooData = True
    Call rsCleanup
    Exit Function
 
Fail:
    storeFooData = False
    Call failHandler("storeFooData", queryStr, err)
End Function
 
Public Function retrieveFooDataById(ByVal fooId As Long) As FooData
    Dim fooD As FooData
    Dim queryStr As String
 
    On Error GoTo Fail
 
    queryStr = "SELECT id, item_name, expiry, stock, is_deleted" & vbNewLine _
        & "FROM foo" & vbNewLine _
        & "WHERE id = ?;"
 
    Set m_cmd = New ADODB.Command
    m_cmd.Parameters.Append m_cmd.CreateParameter(, adUnsignedBigInt, adParamInput, 10, fooId)
 
    Call executeQuery(queryStr, "retrieveFooDataById")
 
    If Not m_rs.EOF Then
        Set fooD = New FooData
        fooD.id = m_rs("id")
        fooD.name = m_rs("item_name")
        fooD.expiry = getDateTimeNull(m_rs("expiry")) ' Gotcha
        fooD.stock = m_rs("stock")
        fooD.isDeleted = CBool(m_rs("is_deleted"))
    End If
 
    Set retrieveFooDataById = fooD
    Call rsCleanup
    Exit Function
 
Fail:
    Call failHandler("retrieveFooDataById", queryStr, err)
End Function