Feeds:
Posts
Comments

Archive for the ‘Database Access’ Category

Build a custom data access class that you can plug into any Excel application that requires Microsoft SQL Server or Microsoft Access connectivity. This will require two code modules: a class module and a standard module. The standard module is used simply to house the global database class instance, and to create/destroy it when the application workbook opens/closes.

Let’s get right into the code. First create a new workbook and switch to the VBA Editor. Add a reference to “Microsoft ActiveX Data Objects 2.8 Library”. Create a new Class module and name it “clsSQLConnection”. Add the following code to this class module.


clsSQLConnection Code


Option Explicit

'Module-level objects
Private mobjConn As ADODB.Connection
'Module-level variables
Private mblnIntegratedSecurity As Boolean
Private mstrModuleName As String
Private mstrConnectionString As String
Private mstrCurrentServer As String
Private mstrCurrentDatabase As String
Private mstrDatabaseType As String

Private Sub Class_Initialize()
mstrModuleName = "clsSQLConnection"
Set mobjConn = New ADODB.Connection
End Sub

Private Sub Class_Terminate()
On Error Resume Next
mobjConn.Close
Set mobjConn = Nothing
On Error Goto 0
End Sub

Public Property Get ConnectionString() As String
ConnectionString = mstrConnectionString
End Property

Public Property Let ConnectionString(ByVal NewValue As String)
mstrConnectionString = NewValue
End Property

Public Property Get CommandTimeOut() As Integer
    CommandTimeOut = mobjConn.CommandTimeOut
End Property

Public Property Let CommandTimeOut(ByVal NewTimeOut As Integer)
mobjConn.CommandTimeOut = NewTimeOut
End Property

Public Property Get CurrentDatabase() As Integer
'Read-only property
CurrentDatabase = mstrCurrentDatabase
End Property

Public Property Get CurrentServer() As String
'Read-only property
CurrentServer = mstrCurrentServer
End Property

Public Property Get DatabaseType() As String
DatabaseType = mstrDatabaseType
End Property

Public Property Let DatabaseType(ByVal NewValue As String)
mstrDatabaseType = NewValue
End Property

Public Property Get IntegratedSecurity() As Boolean
IntegratedSecurity = mblnIntegratedSecurity
End Property

Public Property Let IntegratedSecurity(ByVal NewValue As Boolean)
mblnIntegratedSecurity = NewValue
End Property

Public Sub CloseDB()
'Close connection to database.

On Error Resume Next
If Not mobjConn Is Nothing Then
If mobjConn.State And adStateOpen Then
'Connection is defined and still open; close it.
mobjConn.Close
End If
End If
On Error GoTo 0

End Sub

Public Sub ShowErrorMessages(ByVal StandardErrorObject As VBA.ErrObject, _
ByVal SourceModule As String, ByVal SourceMethod As String)
'Construct a comprehensive error message based on the passed objects.
Dim strMsg As String

'Handle the standard error, if any.
If StandardErrorObject.Number < > 0 Then
strMsg = "Error: " & CStr(Err.Number) & vbCrLf & vbCrlf & "Description: " & _
Err.Description & vbCrLf & vbCrLf
End If

'Include the database-related errors, if any.
If Not (gobjDB Is Nothing) Then
strMsg = strMsg & gobjDB.ADOErrors()
End If

'Finally, tack on the module/method names.
strMsg = strMsg & SourceModule & "::" & SourceMethod & vbCrLf

Err.Clear

MsgBox strMsg, vbCritical, "Contact Technical Support For Assistance"

End Sub

Public Function ADOErrors() As String
'Return a fully formatted string containing any current ADO errors in the collection.
Dim lngCount As Long
Dim objErr as ADODB.Error
Dim strReturn As String

strReturn = vbNullString

For Each objErr in mobjConn.Errors
strReturn = strReturn & CStr(objErr.Number) _
& vbCrLf & objErr.Description & vbCrLf & vbCrLf
Next objErr
mobjConn.Errors.Clear

ADOErrors = strReturn

End Function

Public Function OpenDB(Optional ByVal DatabaseType As String, _
Optional ByVal TargetServer As String = "", _
Optional ByVal TargetDatabase As String = "", _
Optional ByVal IntegratedSecurity As Boolean = False) As Boolean
'Open a connection to the specified server and database, if not already open.
'If the parameters are not specified, then just re-use the last connection
' string that was created.

Dim blnNewConnect As Boolean, blnReturn As Boolean
Dim strDataSource As String
Dim strDB As String
Dim strConn As String

blnReturn = True
blnNewConnect = True

On Error GoTo ODError

If Not mobjConn Is Nothing Then
If mobjConn.State And adStateOpen Then
'Connection is alread defined and opened.
blnNewConnect = False
End If
End If

If blnNewConnect Then
'Must create a new connection
If TargetServer = "" Or TargetDatabase = "" Then
'Calling routine has not specified Server or Database values;
' default to last used.

If Len(mstrConnectionString) > 0 Then
strConn = mstrConnectionString
Else
'If full connection string is blank, use the individual Server/Environment and
' Database variables to determine connection.

strConn = BuildConnectionString(mstrDatabaseType, mstrCurrentServer, _
mstrCurrentDatabase, mblnIntegratedSecurity)
End If
Else
'Build connection string, based on passed arguments
strConn = BuildConnectionString(DatabaseType, TargetServer, TargetDatabase, _
mblnIntegratedSecurity)
End If
mobjConn.ConnectionString = strConn
mobjConn.Open
End If

ODResume:
OpenDB = blnReturn
Exit Function

ODError:
blnReturn = False
ShowErrorMessages Err, mstrModuleName, "OpenDB"
Resume ODResume

End Function

Public Function BuildConnectionString(ByVal DatabaseType As String, _
ByVal TargetServer As String, _
ByVal TargetDatabase As String, _
ByVal IntegratedSecurity As Boolean, _
Optional ByVal UserID As String, _
Optional ByVal Password As String) As String
'Construct a full connection string, set local properties, and
' return string to calling routine.

'Build connection string
Select Case DatabaseType
Case "SQLServer"
'Microsoft SQL Server; use proper network library.
mstrConnectionString = "Network Library=DBMSSOCN;" & _
"PROVIDER=SQLOLEDB;DATA SOURCE=" & TargetServer & _
";INITIAL CATALOG=" & TargetDatabase & _
";Trusted_Connection=yes"
If IntegratedSecurity Then
mstrConnectionString = "Provider=SQLNCLI10;" & _
"Server=" & TargetServer & ";" & _
"Database=" & TargetDatabase & ";" & _
"Trusted_Connection=yes;"
End If
Case "Access2003"
'Access 2003 and prior
mstrConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.Path & "\" & _
TargetDatabase & ".mdb;"
Case "Access2007"
'Access 2007 or 2010
mstrConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ThisWorkbook.Path & "\" & _
TargetDatabase & ".accdb;Persist Security Info=Flase;"
Case Else
'Some other server; modify to accommodate.
mstrConnectionString = "Provider=SQLNCLI10;Server=" & TargetServer & _
";Database=" & TargetDatabase & ";Trusted_Connection=yes;"
End Select

'Update the module variables
mstrCurrentServer = TargetServer
mstrCurrentDatabase = TargetDatabase
mblnIntegratedSecurity = IntegratedSecurity

BuildConnectionString = mstrConnectionString

End Function

Public Function ExecuteSPWithADOCommand(StoredProcName As String, _
OutputParameter As String, OutputValue As Variant, _
ParamArray InputParameters() As Variant) As Boolean
'Execute a stored procedure, using an ADO command object. The InputParameters
' paramarray must contain pairs of data (i.e. element 0 should be Parameter name,
' with leading '@', and element 1 should be the associated parameter value; then
' element 2 is the next parameter name, element 3 is the next parameter value, etc.).
' Also allows for a single Output parameter and associated return value
' (OutputParmeter and OutputValue ByRef parameters). Remember
' to prefix the OutputParmeter name with '@', same as the input parameters.

Dim objCmd As ADODB.Command
Dim blnReturn As Boolean
Dim intParam As Integer
Dim strParamName As String
Dim vntParamValue As Variant

blnReturn = True

On Error GoTo ESPError

If OpenDB() Then
Set objCmd = New ADODB.Command
With objCmd
.ActiveConnection = mobjConn
.CommandText = StoredProcName
.CommandType = adCmdStoredProc
.Parameters.Refresh
'Define the Input Parameters
For intParam = 0 To UBound(InputParameters) Step 2
.Parameters(InputParameters(intParam)).Value = _
InputParameters(intParam + 1)
Next intParam
'Define the single allowed output parameter, if any
If Len(Trim(OutputParameter)) > 0 Then
.Parameters(OutputParameter).Direction = adParamOutput
End If
'Execute the stored procedure
.Execute
End With

'Retrieve the value of the output parameter (if any)
If Len(Trim(OutputParameter)) > 0 Then
OutputValue = objCmd.Parameters(OutputParameter).Value
Else
OutputValue = vbNullString
End If
Else
'No database connection could be established, but no error
' was raised (should never happen).

OutputValue = vbNullString
blnReturn = False
End If

ESPResume:
ExecuteSPWithADOCommand = blnReturn
Set objCmd = Nothing
CloseDB
Exit Function

ESPError:
blnReturn = False
ShowErrorMessages Err, mstrModuleName, "ExecuteSPWithADOCommand"
Resume ESPResume

End Function

Function GetRecordset(strSQL As String) As ADODB.Recordset
'Return a disconnected recordset from the database.
Dim rst As ADODB.Recordset

On Error GoTo GRError

If OpenDB() Then
Set rst = New ADODB.Recordset
rst.CursorLocation = adUseClient
rst.Open strSQL, mobjConn, adOpenDynamic

Set GetRecordset = rst
rst.ActiveConnection = Nothing
End If

GRResume:
CloseDB
Exit Function

GRError:
ShowErrorMessages Err, mstrModuleName, "GetRecordset"
Resume GRResume

End Function

Public Function GetRecordsetToArray(strSQL As String) As Variant
'Return recordset data into an array. If, for any reason, the recordset
' does not return any data, this function simply creates a single element
' array and populates it with "No matching records...".

Dim rst As ADODB.Recordset
Dim arrData As Variant
Dim lngX As Long

On Error GoTo GRAError

If OpenDB() Then
Set rst = New ADODB.Recordset
With rst
.CursorLocation = adUseClient
.LockType = adLockReadOnly
.Open strSQL, mobjConn, adOpenStatic

If Not (rst.EOF) Then
'Disconnect the recordset
.ActiveConnection = Nothing
'Get the field count
lngX = .Fields.Count
arrData = .GetRows()
Else
'Recordset is empty; create dummy array record
ReDim arrData(0, 0)
arrData(0, 0) = "No matching records found in the database"
End If
End With
Else
'Connection failed for some reason; in order not to crash the
' calling routine, create dummy array record.

ReDim arrData(0, 0)
arrData(0, 0) = "Could not open database connection"
End If

GRAResume:
GetRecordsetToArray = arrData
CloseDB
Exit Function

GRAError:
ShowErrorMessages Err, mstrModuleName, "GetRecordsetToArray"
Resume GRAResume

End Function

Public Function GetMultipleRecordsets(strSQL As String) As ADODB.Recordset
'Allows for multiple recordsets to be returned to the calling routine.
'IMPORTANT - Although this method is similar to the GetRecordSet function,
' there are significant differences.
' 1. Do not disconnect the Recordset (i.e. don't set ActiveConnection to Nothing).
' 2. You must not close the database connection! It must remain open so that
' the calling routine can retrieve all of the resultsets in the returned Recordset.
' IT IS UP TO THE CALLING ROUTINE TO CLOSE THE CONNECTION WHEN DONE.

Dim rst As ADODB.Recordset

On Error GoTo GMRError

If OpenDB() Then
Set rst = New ADODB.Recordset
rst.Open strSQL, mobjConn

Set GetMultipleRecordsets = rst
End If

GMRResume:
'REMEMBER! Do NOT close the connection here. Calling routine must close it.
Exit Function

GMRError:
ShowErrorMessages Err, mstrModuleName, "GetMultipleRecordsets"
Resume GMRResume

End Function

Public Function ExecuteActionQuery(SQLToExecute As String) As Boolean
'Execute an action query, or stored procedure, which is not expected
' to return a resultset.

Dim blnReturn As Boolean

blnReturn = True

On Error GoTo EAQError

If OpenDB() Then
mobjConn.Execute SQLToExecute
End If

EAQResume:
CloseDB
ExecuteActionQuery = blnReturn
Exit Function

EAQError:
blnReturn = False
ShowErrorMessages Err, mstrModuleName, "ExecuteActionQuery"
Resume EAQResume

End Function

Public Property Get SQLConnection() As ADODB.Connection
'Return the actual connection object, if requested by
' calling routine.

If Not mobjConn Is Nothing Then
On Error Resume Next
Set SQLConnection = mobjConn
On Error GoTo 0
End If

End Property


modGlobal Code

Next, insert a new standard module, name it modGlobal and copy the following code:


Option Explicit

'Global data access class object
Public gobjDB As clsSQLConnection

Public Sub InitializeDatabase()
Dim strDatabaseType As String
Dim strServerName As String
Dim strDatabaseName As String
Dim blnIntegratedSecurity As Boolean
Dim strUserID As String
Dim strPassword As String

'*** NOTE: The database properties and user ID, etc. can be read from an
' INI file or some other source. For this example, just hard-code
' the server and database values and assume that Windows integrated
' security is being used (so no UID or Pwd are required).
' This procedure assumes that you have a local SQL Server
' installation, with a database named "MyDatabase".
' Modify this as necessary to conform to your test environment.

strDatabaseType = "SQLServer"
strServerName = "(local)"
strDatabaseName = "MyDatabase"
blnIntegratedSecurity = True

Set gobjDB = New clsSQLConnection
gobjDB.BuildConnectionString strDatabaseType, strServerName, _
strDatabaseName, blnIntegratedSecurity

End Sub

Public Sub DestroyDatabase()

If Not (gobjDB Is Nothing) Then
On Error Resume Next
gobjDB.CloseDB
Set gobjDB = Nothing
End If

End Sub

Public Sub TestDataAccess()
'Test everything to make sure it works.
'NOTE: This procedure assumes there is a database
' table named "MyTestTable" that has at least two
' fields: "Field1" and "Field2". Modify to match
' your specifics.

Dim rsTest As ADODB.RecordSet
Dim lngRow As Long

Set rsTest = gobjDB.GetRecordSet("SELECT * FROM MyTestTable")
If Not (rsTest Is Nothing) Then
If Not rsTest.EOF Then
lngRow = 1
Do While Not rsTest.EOF
ActiveSheet.Range("A" & lngRow).Value = rsTest("Field1").Value
ActiveSheet.Range("B" & lngRow).Value = rsTest("Field2").Value
rsTest.MoveNext
lngRow = lngRow + 1
Loop
End If
End If

End Sub


Workbook Code

Finally, in order to have the database connection initialized when the workbook opens, and destroyed when the workbook closes, add the following code to the “ThisWorkbook” object:


Option Explicit

Private Sub Workbook_Open()
InitializeDatabase 'Make call to global subroutine.
End Sub

Private Sub Workbook_BeforeClose()
DestroyDatabase
End Sub


IMPORTANT: Remember that you must change the property values in the InitializeDatabase function to match your SQL Server values, and you must modify the table and field names for your test query in the TestDataAccess subroutine


That’s all you need to have a fully functional set of database access routines that can be plugged into any Excel workbook. Of course, there’s more functionality that can be added to the clsSQLConnection class module, such as application-specific stored procedure calls, database transaction management, etc. Use this as a starting point for your work, and modify as needed.

+MD

Advertisements

Read Full Post »