In this post, I thought I would share some ideas about creating a Data Access Layer in VBA for SQL Server. The idea behind creating this layer is to organize all the low level coding tasks associated with accessing a SQL Server database into one area in an application. Typically, these tasks involve writing methods using ADO (Active Data Objects) to either fetch data or process some database command. The idea behind the layer is to encapsulate these methods, and then make them available via the layer to other parts of the application that need to carry out database tasks.
Objectives
There are a number of reasons for organizing code in this way:
- It simplifies the code involved with interacting with a database.
- It leads to a clear separation between the low level database tasks and the main application code.
- It allows for client side database access to be tested independently of any user interface.
- It standardizes access to the database and ensures consistency across the application.
- The layer is portable and can be reused in other applications.
- It avoids code repetition, by allowing for generic methods that can carry out tasks.
- The database implementation can be changed without impacting code outside of the layer.
- It allows for server credentials to be stored centrally in an application.
The Design
There are many different ways you can implement a Data Access Layer in VBA, in my case I have opted for the following design:
Database Tasks
In the design, the main class is called clsDatabase, and it has two main methods:
- GetRecordsetFromStoredProc
- ExecuteStoredProc
The first method is to used to retrieve data from the database and the second is used to execute SQL Server tasks wrapped in stored procedures. With ADO, it is possible to send SQL statements directly to a database to query its raw tables. However it is best to avoid this, and actually prevent its possibility. This is because it can lead to security vulnerabilities and allow for the possibility of a SQL injection attack. Additionally, when it comes to performance, database operations are always better handled server side rather than client side. This class ensures that the only communication between the application client and the database occurs via stored procedures. The class also has methods that allow for parameters to be added to any stored procedure that requires them.
Encapsulation
A key feature of the clsDatabase class, is that it operates as a black box. It should not expose ADO tasks or methods to any other area of code. All of these need to be enclosed within the layer. The one exception to this, will be that the class will have to return data as an ADO Recordset to outside calling code. This is because some VBA methods require a Recordset object as an argument in order to work. The most notable example of this is the CopyFromRecordSet method of the Range object in Excel. I could expand the class to handle this Range method and incorporate outputting the data to a worksheet. However, this would tie the layer down to a specific platform i.e. Excel. The layer should be independent of this, so it can be used in other Office Applications like Microsoft Access. So apart from the method that gets data, the other methods in my class either return standard variable types such as a Boolean value to indicate whether a task completed, or a string message to indicate an error.
Handling Multiple Databases
In the design, I have decoupled connection information from the main class, and created another class for this called clsDBCredentals. This class is used to specify the server details and database name as well as how to connect to SQL Server. The main class clsDatabase simply needs an instance of the clsDBCredentials class to perform its tasks. The reason for this separation is because I wanted to allow for the design of the layer to be flexible enough to cope with connecting to multiple databases. This scenario can come up if I am working with a production database that also has a development and UAT environment.
The Layer’s Factory
The purpose of the clsDBInstance class is to handle the responsibility of creating objects using the clsDatabase and clsDBCredential classes. It simplifies the process of having two classes. It is here that I specify the details of multiple databases. This allows for my main classes to be kept closed for modification, a key characteristic of encapsulation in object-orientated design. The class also offers different ways it can create an instance of the clsDatabase class, adding greater flexibility to this approach.
Singleton Design Pattern
With the GetSharedDatabase method, I use a Singleton design pattern to offer the possibility of reusing an open instance of the database class within the layer. Repeatedly opening and closing a database can be a wasteful process. The shared connection method creates a single instance of the database object and reuses it for other tasks if it is open and available.
Implementing the Design in VBA
In order to use the following code, the following references need to be checked in the VBA Reference Window:
The code requires the creation of three VBA classes called clsDatabase, clsDBInstance and clsDBCredentials.
The following is the code for the main class clsDatabase:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 |
Option Explicit Private Const CLNG_DEFAULT_TIMEOUT As Long = 0 Private Const CINT_PARAMETER_FIELDS_COUNT As Integer = 5 Private moConn As New ADODB.Connection Private mstrConnectionString As String Private mstrADOErrors As String Private mlngCmdTimeOut As Long Private mvarParams() As Variant Private Enum EnuParameters Name = 0 DataType = 1 Length = 2 Value = 3 Direction = 4 End Enum Public Property Get ConnectionErrors() As String ConnectionErrors = mstrADOErrors End Property Private Sub Class_Initialize() mstrADOErrors = Empty mlngCmdTimeOut = CLNG_DEFAULT_TIMEOUT ReDim mvarParams(CINT_PARAMETER_FIELDS_COUNT, 0) End Sub Public Function OpenDatabase(ByVal objCred As clsDBCredentials) As Boolean On Error GoTo ERR_HANDLER: OpenDatabase = False If (moConn Is Nothing) Or (moConn.State = adStateClosed) Then mstrConnectionString = objCred.GetConnectionString moConn.Open mstrConnectionString End If OpenDatabase = True EXIT_HERE: Exit Function ERR_HANDLER: OpenDatabase = False mstrADOErrors = GetADOErrorInformation() mstrADOErrors = mstrADOErrors & vbCrLf & "Err Description:" & Err.Description Set moConn = Nothing GoTo EXIT_HERE End Function Public Function CloseDatabase() As Boolean On Error GoTo ERR_HANDLER: CloseDatabase = False If (Not moConn Is Nothing) Or (moConn.State = adStateOpen) Then moConn.Close Set moConn = Nothing End If CloseDatabase = True EXIT_HERE: Exit Function ERR_HANDLER: CloseDatabase = False GoTo EXIT_HERE End Function Public Sub ClearParamList() ReDim mvarParams(CINT_PARAMETER_FIELDS_COUNT, 0) End Sub Public Sub AddToParamList(ByVal strParamName As String, _ ByVal dblDataType As Double, _ ByVal dblDataLength As Double, _ ByVal varParamValue As Variant, _ ByVal intParamDirection As Integer) Dim intArrayElement As Integer Dim intArrayBound As Integer intArrayBound = UBound(mvarParams(), 2) intArrayElement = intArrayBound intArrayBound = intArrayBound + 1 ReDim Preserve mvarParams(CINT_PARAMETER_FIELDS_COUNT, intArrayBound) mvarParams(EnuParameters.Name, intArrayElement) = strParamName mvarParams(EnuParameters.DataType, intArrayElement) = dblDataType mvarParams(EnuParameters.Length, intArrayElement) = dblDataLength mvarParams(EnuParameters.Value, intArrayElement) = varParamValue mvarParams(EnuParameters.Direction, intArrayElement) = intParamDirection End Sub Public Function GetParamValue(ByVal strParamName As String) As Variant Dim intIndex As Integer For intIndex = LBound(mvarParams, 2) To UBound(mvarParams, 2) - 1 If mvarParams(EnuParameters.Name, intIndex) = strParamName Then GetParamValue = mvarParams(EnuParameters.Value, intIndex) Exit Function End If Next intIndex End Function Private Function GetADOErrorInformation() As String Dim lngErrorCount As Long Dim lngErrorIndex As Long Dim oError As ADODB.Error Dim oErrorColl As ADODB.Errors Dim strErr As String If moConn Is Nothing Then GoTo EXIT_HERE Else Set oErrorColl = moConn.Errors End If lngErrorCount = oErrorColl.Count If (lngErrorCount > 0) Then strErr = "Errors reported by ADO" & vbCrLf End If For lngErrorIndex = 0 To (lngErrorCount - 1) Set oError = oErrorColl.Item(lngErrorIndex) With oError strErr = strErr & "(" & lngErrorIndex + 1 & ") " strErr = strErr & "Error#: " & .Number & vbCrLf strErr = strErr & vbTab & "Desc : " & .Description & vbCrLf strErr = strErr & vbTab & "Source: " & .Source & vbCrLf strErr = strErr & vbTab & "Native Error: " & .NativeError & vbCrLf strErr = strErr & vbTab & "SQL State: " & .SqlState & vbCrLf strErr = strErr & vbTab & "Help Context: " & .HelpContext & vbCrLf strErr = strErr & vbTab & "Help File: " & .HelpFile & vbCrLf End With Next lngErrorIndex GetADOErrorInformation = strErr EXIT_HERE: Set oError = Nothing Set oErrorColl = Nothing End Function Public Function IsConnected() As Boolean IsConnected = False If Not moConn Is Nothing Then IsConnected = IIf(moConn.State = adStateOpen, True, False) End If End Function Public Function ExecuteStoredProc(ByVal strQueryName As String) As Boolean On Error GoTo ERR_HANDLER Dim intParam As Integer Dim prmParameter As ADODB.Parameter Dim objCommand As ADODB.Command Set objCommand = New ADODB.Command ExecuteStoredProc = False mstrADOErrors = Empty If Not IsConnected Then GoTo EXIT_HERE End If With objCommand .ActiveConnection = moConn .CommandTimeout = mlngCmdTimeOut .CommandType = adCmdStoredProc .CommandText = "[" & strQueryName & "]" For intParam = LBound(mvarParams, 2) To UBound(mvarParams, 2) - 1 Set prmParameter = objCommand.CreateParameter(mvarParams(EnuParameters.Name, intParam), mvarParams(EnuParameters.DataType, intParam), mvarParams(EnuParameters.Direction, intParam), mvarParams(EnuParameters.Length, intParam), mvarParams(EnuParameters.Value, intParam)) objCommand.Parameters.Append prmParameter Next intParam .Execute End With For intParam = LBound(mvarParams, 2) To UBound(mvarParams, 2) - 1 mvarParams(EnuParameters.Value, intParam) = objCommand.Parameters(intParam).Value Next intParam ExecuteStoredProc = True EXIT_HERE: Set objCommand = Nothing Set prmParameter = Nothing Exit Function ERR_HANDLER: mstrADOErrors = GetADOErrorInformation() mstrADOErrors = mstrADOErrors & vbCrLf & "Err Description:" & Err.Description ExecuteStoredProc = False GoTo EXIT_HERE End Function Public Function GetRecordsetFromStoredProc(ByVal strQueryName As String, _ Optional ByVal intCursorType = adOpenKeyset, _ Optional ByVal intLockType = adLockOptimistic, _ Optional ByVal intCursorLocation = adUseClient) As ADODB.Recordset On Error GoTo ERR_HANDLER Dim intParam As Integer Dim prmParameter As ADODB.Parameter Dim objCommand As ADODB.Command Dim rstOutput As ADODB.Recordset Set objCommand = New ADODB.Command Set rstOutput = New ADODB.Recordset Set GetRecordsetFromStoredProc = Nothing mstrADOErrors = Empty If Not IsConnected Then GoTo EXIT_HERE End If With objCommand .ActiveConnection = moConn .CommandTimeout = mlngCmdTimeOut .CommandType = adCmdStoredProc .CommandText = strQueryName For intParam = LBound(mvarParams, 2) To UBound(mvarParams, 2) - 1 Set prmParameter = objCommand.CreateParameter(mvarParams(EnuParameters.Name, intParam), mvarParams(EnuParameters.DataType, intParam), mvarParams(EnuParameters.Direction, intParam), mvarParams(EnuParameters.Length, intParam), mvarParams(EnuParameters.Value, intParam)) objCommand.Parameters.Append prmParameter Next intParam objCommand.ActiveConnection.CursorLocation = intCursorLocation rstOutput.CursorType = intCursorType rstOutput.LockType = intLockType Set rstOutput = .Execute End With For intParam = LBound(mvarParams, 2) To UBound(mvarParams, 2) - 1 mvarParams(EnuParameters.Value, intParam) = objCommand.Parameters(intParam).Value Next intParam Set GetRecordsetFromStoredProc = rstOutput EXIT_HERE: Set objCommand = Nothing Set prmParameter = Nothing Set rstOutput = Nothing Exit Function ERR_HANDLER: mstrADOErrors = GetADOErrorInformation() mstrADOErrors = mstrADOErrors & vbCrLf & "Err Description:" & Err.Description Set GetRecordsetFromStoredProc = Nothing GoTo EXIT_HERE End Function |
Note: In my class, I have a private method called GetInformationError which is based upon this post from devX.com.
This is the code for the class csDBInstance:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
Option Explicit Private objSharedClass As clsDatabase Public Function GetNewDatabase(Optional ByVal DBName As String) As clsDatabase Set GetNewDatabase = CreateDatabase(DBName) End Function Public Function GetSharedDatabase(Optional ByVal DBName As String) As clsDatabase If objSharedClass Is Nothing Then Set objSharedClass = CreateDatabase(DBName) End If Set GetSharedDatabase = objSharedClass End Function Public Function CloseSharedDatabase() As Boolean CloseSharedDatabase = objSharedClass.CloseDatabase Set objSharedClass = Nothing End Function Private Function CreateDatabase(Optional ByVal Name As String) As clsDatabase Dim objDatabase As clsDatabase Dim objDBCredentials As clsDBCredentials Set objDBCredentials = New clsDBCredentials Set objDatabase = New clsDatabase objDBCredentials.SetServer = "WORK-PC" objDBCredentials.SetDBName = "DataAccessDemo" objDBCredentials.SetTrustedSecurity = True objDatabase.OpenDatabase objDBCredentials Set CreateDatabase = objDatabase End Function |
The name of the server and database need to be changed to whatever database is being worked upon. The code above is setup to use trusted security. However, if a login and password is required then the trusted security attribute needs to be false, and the login and password need to be added like so:
1 2 3 |
objDBCredentials.SetPassword = "MyPassword" objDBCredentials.SetUserId = "MyLogin" objDBCredentials.SetTrustedSecurity = False |
Finally, this is the code for the class csDBCredentials:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 |
Option Explicit Private Const CSTR_PROVIDER As String = "sqloledb" Private mstrServer As String Private mstrDBName As String Private mstrPassword As String Private mstrUserID As String Private mstrConnectionString As String Private mblnUsedTrustedSecurity As Boolean Public Property Let SetUserId(ByVal Value As String) mstrUserID = Value End Property Public Property Let SetPassword(ByVal Value As String) mstrPassword = Value End Property Public Property Let SetDBName(ByVal Value As String) mstrDBName = Value End Property Public Property Let SetServer(ByVal Value As String) mstrServer = Value End Property Public Property Let SetTrustedSecurity(ByVal Value As Boolean) mblnUsedTrustedSecurity = Value End Property Public Function GetConnectionString() If mblnUsedTrustedSecurity Then mstrConnectionString = _ "Provider=" & CSTR_PROVIDER & ";Data Source=" & mstrServer & ";Initial Catalog=" & mstrDBName & ";Integrated Security=SSPI" Else mstrConnectionString = _ "Provider=" & CSTR_PROVIDER & ";Data Source=" & mstrServer & ";Initial Catalog=" & mstrDBName & ";User ID='" & mstrUserID & "';Password='" & mstrPassword & "';" End If GetConnectionString = mstrConnectionString End Function Private Sub Class_Initialize() mblnUsedTrustedSecurity = False End Sub |
In the next post, I will show some examples of how the above classes are used in a real world context.
Thank you for reading this post. Please take time to read the disclaimer about content found on this site.
Share :



