' 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
