\$\begingroup\$\$\endgroup\$
I recently postedthis question on my implementation of an ADODB Wrapper Class. I realized in my ownreview that I was missing some very important things, so much so, that I decided it would be worth it to re-write the entire class. Saying that I have done quite a bit of restructuring so I am going to provide an outline of what I have done and why.
Numeric Parameters:
I removed the public propertiesParameterNumericScale andParameterPrecision as I was not considering the possibility of a parameters with varyingprecision andnumericscale. To address this, I created 2 functions that automatically calculate theprecision andnumericscale for each parameter passed in:
Private Function CalculatePrecision(ByVal Value As Variant) As Byte CalculatePrecision = CByte(Len(Replace(CStr(Value), ".", vbNullString)))End FunctionPrivate Function CalculateNumericScale(ByVal Value As Variant) As Byte CalculateNumericScale = CByte(Len(Split(CStr(Value), ".")(1)))End FunctionADO Connection Error's Collection:
I opted to pass theConnection.Errors collection alone, instead of the entire Connection Object to each of the sub proceduresValidateConnection andPopulateADOErrorObject:
Private Sub ValidateConnection(ByVal ConnectionErrors As ADODB.Errors) If ConnectionErrors.Count > 0 Then If Not this.HasADOError Then PopulateADOErrorObject ConnectionErrors Dim ADOError As ADODB.Error Set ADOError = GetError(ConnectionErrors, ConnectionErrors.Count - 1) 'Note: 0 based collection Err.Raise ADOError.Number, ADOError.Source, ADOError.Description, ADOError.HelpFile, ADOError.HelpContext End IfEnd SubBi-Directional Parameters:
Previously, I was only considering the use of Input Parameters for a given command, because there is no way to know what Direction a parameter should be mapped. However, I was able to come up with something close to this, by implicitly calling theParameters.Refresh method of theParameters collection object. Note that Parameters STILL have to be passed in the correct order or ADO will populate theConnection.Errors collection. It is also worth mentioning that this has a very small (virtually unnoticeable) performance hit, but even still, I chose to leave it up to the client to choose which method that they want use. I did so by adding a boolean property calledDeriveParameterDirection, which If set to true, then theDerivedDirectionParameters implementation of theIADODBParametersWrapper will be used, in the privateCreateCommand procedure. If false, then theAssumeParameterDirection ofIADODBParametersWrapper will be used.
Also, If output parameters are used, you need a way to return them, so I use the following inADODBWrapper to do so:
'note: this.OuputParameters is a read only property at the class levelPrivate Sub PopulateOutPutParameters(ByRef Parameters As ADODB.Parameters)Dim Param As ADODB.ParameterSet this.OuputParameters = New CollectionFor Each Param In Parameters Select Case Param.Direction Case adParamInputOutput this.OuputParameters.Add Param Case adParamOutput this.OuputParameters.Add Param Case adParamReturnValue this.OuputParameters.Add Param End SelectNextEnd SubIADODBParametersWrapper (Interface):
Option ExplicitPublic Sub SetParameters(ByRef Command As ADODB.Command, ByRef ParameterValues As Variant)End SubPrivate Sub Class_Initialize() Err.Raise vbObjectError + 1024, TypeName(Me), "An Interface class must not be instantiated."End SubAssumedDirectionParameters (Class):
Option ExplicitImplements IADODBParametersWrapperPrivate Sub IADODBParametersWrapper_SetParameters(ByRef Command As ADODB.Command, ByRef ParameterValues As Variant) Dim i As Long Dim ParamVal As Variant If UBound(ParameterValues) = -1 Then Exit Sub 'not allocated For i = LBound(ParameterValues) To UBound(ParameterValues) ParamVal = ParameterValues(i) Command.Parameters.Append ToADOInputParameter(ParamVal) Next iEnd SubPrivate Function ToADOInputParameter(ByVal ParameterValue As Variant) As ADODB.Parameter Dim ResultParameter As New ADODB.Parameter With ResultParameter Select Case VarType(ParameterValue) Case vbInteger .Type = adInteger Case vbLong .Type = adInteger Case vbSingle .Type = adSingle .Precision = CalculatePrecision(ParameterValue) .NumericScale = CalculateNumericScale(ParameterValue) Case vbDouble .Type = adDouble .Precision = CalculatePrecision(ParameterValue) .NumericScale = CalculateNumericScale(ParameterValue) Case vbDate .Type = adDate Case vbCurrency .Type = adCurrency .Precision = CalculatePrecision(ParameterValue) .NumericScale = CalculateNumericScale(ParameterValue) Case vbString .Type = adVarChar .Size = Len(ParameterValue) Case vbBoolean .Type = adBoolean End Select .Direction = ADODB.ParameterDirectionEnum.adParamInput .value = ParameterValue End With Set ToADOInputParameter = ResultParameterEnd FunctionPrivate Function CalculatePrecision(ByVal value As Variant) As Byte CalculatePrecision = CByte(Len(Replace(CStr(value), ".", vbNullString)))End FunctionPrivate Function CalculateNumericScale(ByVal value As Variant) As Byte CalculateNumericScale = CByte(Len(Split(CStr(value), ".")(1)))End FunctionDerivedDirectionParameters (Class):
Option ExplicitImplements IADODBParametersWrapperPrivate Sub IADODBParametersWrapper_SetParameters(ByRef Command As ADODB.Command, ByRef ParameterValues As Variant) Dim i As Long Dim ParamVal As Variant If UBound(ParameterValues) = -1 Then Exit Sub 'not allocated With Command If .Parameters.Count = 0 Then Err.Raise vbObjectError + 1024, TypeName(Me), "This Provider does " & _ "not support parameter retrieval." End If Select Case .CommandType Case adCmdStoredProc If .Parameters.Count > 1 Then 'Debug.Print Cmnd.Parameters.Count prints 1 b/c it includes '@RETURN_VALUE' 'which is a default value For i = LBound(ParameterValues) To UBound(ParameterValues) ParamVal = ParameterValues(i) 'Explicitly set size to prevent error 'as per the Note at: https://docs.microsoft.com/en-us/sql/ado/reference/ado-api/refresh-method-ado?view=sql-server-2017 SetVariableLengthProperties .Parameters(i + 1), ParamVal .Parameters(i + 1).Value = ParamVal '.Parameters(i + 1) b/c of @RETURN_VALUE 'mentioned above Next i End If Case adCmdText For i = LBound(ParameterValues) To UBound(ParameterValues) ParamVal = ParameterValues(i) 'Explicitly set size to prevent error SetVariableLengthProperties .Parameters(i), ParamVal .Parameters(i).Value = ParamVal Next i End Select End WithEnd SubPrivate Sub SetVariableLengthProperties(ByRef Parameter As ADODB.Parameter, ByRef ParameterValue As Variant) With Parameter Select Case VarType(ParameterValue) Case vbSingle .Precision = CalculatePrecision(ParameterValue) .NumericScale = CalculateNumericScale(ParameterValue) Case vbDouble .Precision = CalculatePrecision(ParameterValue) .NumericScale = CalculateNumericScale(ParameterValue) Case vbCurrency .Precision = CalculatePrecision(ParameterValue) .NumericScale = CalculateNumericScale(ParameterValue) Case vbString .Size = Len(ParameterValue) End Select End WithEnd SubPrivate Function CalculatePrecision(ByVal value As Variant) As Byte CalculatePrecision = CByte(Len(Replace(CStr(value), ".", vbNullString)))End FunctionPrivate Function CalculateNumericScale(ByVal value As Variant) As Byte CalculateNumericScale = CByte(Len(Split(CStr(value), ".")(1)))End FunctionADODBWrapper (Class):
Option ExplicitPrivate Type TADODBWrapper DeriveParameterDirection As Boolean CommandTimeout As Long OuputParameters As Collection ADOErrors As ADODB.Errors HasADOError As BooleanEnd TypePrivate this As TADODBWrapperPublic Property Get DeriveParameterDirection() As Boolean DeriveParameterDirection = this.DeriveParameterDirectionEnd PropertyPublic Property Let DeriveParameterDirection(ByVal value As Boolean) this.DeriveParameterDirection = valueEnd PropertyPublic Property Get CommandTimeout() As Long CommandTimeout = this.CommandTimeoutEnd PropertyPublic Property Let CommandTimeout(ByVal value As Long) this.CommandTimeout = valueEnd PropertyPublic Property Get OuputParameters() As Collection Set OuputParameters = this.OuputParametersEnd PropertyPublic Property Get Errors() As ADODB.Errors Set Errors = this.ADOErrorsEnd PropertyPublic Property Get HasADOError() As Boolean HasADOError = this.HasADOErrorEnd PropertyPrivate Sub Class_Terminate() With this .CommandTimeout = Empty .DeriveParameterDirection = Empty Set .OuputParameters = Nothing Set .ADOErrors = Nothing .HasADOError = Empty End WithEnd SubPublic Function GetRecordSet(ByRef Connection As ADODB.Connection, _ ByVal CommandText As String, _ ByVal CommandType As ADODB.CommandTypeEnum, _ ByVal CursorType As ADODB.CursorTypeEnum, _ ByVal LockType As ADODB.LockTypeEnum, _ ParamArray ParameterValues() As Variant) As ADODB.Recordset Dim Cmnd As ADODB.Command ValidateConnection Connection.Errors On Error GoTo CleanFail Set Cmnd = CreateCommand(Connection, CommandText, CommandType, CVar(ParameterValues)) 'must convert paramarray to 'a variant in order to pass 'to another function 'Note: When used on a client-side Recordset object, ' the CursorType property can be set only to adOpenStatic. Set GetRecordSet = New ADODB.Recordset GetRecordSet.CursorType = CursorType GetRecordSet.LockType = LockType Set GetRecordSet = Cmnd.Execute(Options:=ExecuteOptionEnum.adAsyncFetch) 'if successful If Not this.ADOErrors Is Nothing Then this.ADOErrors.ClearCleanExit: Set Cmnd = Nothing Exit FunctionCleanFail: PopulateADOErrorObject Connection.Errors Resume CleanExitEnd FunctionPublic Function GetDisconnectedRecordSet(ByRef ConnectionString As String, _ ByVal CursorLocation As ADODB.CursorLocationEnum, _ ByVal CommandText As String, _ ByVal CommandType As ADODB.CommandTypeEnum, _ ParamArray ParameterValues() As Variant) As ADODB.Recordset Dim Cmnd As ADODB.Command Dim CurrentConnection As ADODB.Connection On Error GoTo CleanFail Set CurrentConnection = CreateConnection(ConnectionString, CursorLocation) Set Cmnd = CreateCommand(CurrentConnection, CommandText, CommandType, CVar(ParameterValues)) 'must convert paramarray to 'a variant in order to pass 'to another function Set GetDisconnectedRecordSet = New ADODB.Recordset With GetDisconnectedRecordSet .CursorType = adOpenStatic 'Must use this cursortype and this locktype to work with a disconnected recordset .LockType = adLockBatchOptimistic .Open Cmnd, , , , Options:=ExecuteOptionEnum.adAsyncFetch 'disconnect the recordset Set .ActiveConnection = Nothing End With 'if successful If Not this.ADOErrors Is Nothing Then this.ADOErrors.ClearCleanExit: Set Cmnd = Nothing If Not CurrentConnection Is Nothing Then: If (CurrentConnection.State And adStateOpen) = adStateOpen Then CurrentConnection.Close Set CurrentConnection = Nothing Exit FunctionCleanFail: PopulateADOErrorObject CurrentConnection.Errors Resume CleanExitEnd FunctionPublic Function QuickExecuteNonQuery(ByVal ConnectionString As String, _ ByVal CommandText As String, _ ByVal CommandType As ADODB.CommandTypeEnum, _ ByRef RecordsAffectedReturnVal As Long, _ ParamArray ParameterValues() As Variant) As Boolean Dim Cmnd As ADODB.Command Dim CurrentConnection As ADODB.Connection On Error GoTo CleanFail Set CurrentConnection = CreateConnection(ConnectionString, adUseServer) Set Cmnd = CreateCommand(CurrentConnection, CommandText, CommandType, CVar(ParameterValues)) 'must convert paramarray to 'a variant in order to pass 'to another function Cmnd.Execute RecordsAffected:=RecordsAffectedReturnVal, Options:=ExecuteOptionEnum.adExecuteNoRecords QuickExecuteNonQuery = True 'if successful If Not this.ADOErrors Is Nothing Then this.ADOErrors.ClearCleanExit: Set Cmnd = Nothing If Not CurrentConnection Is Nothing Then: If (CurrentConnection.State And adStateOpen) = adStateOpen Then CurrentConnection.Close Set CurrentConnection = Nothing Exit FunctionCleanFail: PopulateADOErrorObject CurrentConnection.Errors Resume CleanExitEnd FunctionPublic Function ExecuteNonQuery(ByRef Connection As ADODB.Connection, _ ByVal CommandText As String, _ ByVal CommandType As ADODB.CommandTypeEnum, _ ByRef RecordsAffectedReturnVal As Long, _ ParamArray ParameterValues() As Variant) As Boolean Dim Cmnd As ADODB.Command ValidateConnection Connection.Errors On Error GoTo CleanFail Set Cmnd = CreateCommand(Connection, CommandText, CommandType, CVar(ParameterValues)) 'must convert paramarray to 'a variant in order to pass 'to another function Cmnd.Execute RecordsAffected:=RecordsAffectedReturnVal, Options:=ExecuteOptionEnum.adExecuteNoRecords ExecuteNonQuery = True 'if successful If Not this.ADOErrors Is Nothing Then this.ADOErrors.ClearCleanExit: Set Cmnd = Nothing Exit FunctionCleanFail: PopulateADOErrorObject Connection.Errors Resume CleanExitEnd FunctionPublic Function CreateConnection(ByRef ConnectionString As String, ByVal CursorLocation As ADODB.CursorLocationEnum) As ADODB.Connection On Error GoTo CleanFail Set CreateConnection = New ADODB.Connection CreateConnection.CursorLocation = CursorLocation CreateConnection.Open ConnectionStringCleanExit: Exit FunctionCleanFail: PopulateADOErrorObject CreateConnection.Errors Resume CleanExitEnd FunctionPrivate Function CreateCommand(ByRef Connection As ADODB.Connection, _ ByVal CommandText As String, _ ByVal CommandType As ADODB.CommandTypeEnum, _ ByRef ParameterValues As Variant) As ADODB.Command Dim ParameterGenerator As IADODBParametersWrapper Set CreateCommand = New ADODB.Command With CreateCommand .ActiveConnection = Connection .CommandText = CommandText .CommandTimeout = Me.CommandTimeout '0 End With If Me.DeriveParameterDirection Then Set ParameterGenerator = New DerivedDirectionParameters CreateCommand.CommandType = CommandType 'When set before accessing the Parameters Collection, 'Parameters.Refresh is impilicitly called ParameterGenerator.SetParameters CreateCommand, ParameterValues PopulateOutPutParameters CreateCommand.Parameters Else Set ParameterGenerator = New AssumedDirectionParameters ParameterGenerator.SetParameters CreateCommand, ParameterValues CreateCommand.CommandType = CommandType End IfEnd FunctionPrivate Sub ValidateConnection(ByRef ConnectionErrors As ADODB.Errors) If ConnectionErrors.Count > 0 Then If Not this.HasADOError Then PopulateADOErrorObject ConnectionErrors Dim ADOError As ADODB.Error Set ADOError = GetError(ConnectionErrors, ConnectionErrors.Count - 1) 'Note: 0 based collection Err.Raise ADOError.Number, ADOError.Source, ADOError.Description, ADOError.HelpFile, ADOError.HelpContext End IfEnd SubPrivate Sub PopulateADOErrorObject(ByVal ConnectionErrors As ADODB.Errors) If ConnectionErrors.Count = 0 Then Exit Sub this.HasADOError = True Set this.ADOErrors = ConnectionErrorsEnd SubPublic Function ErrorsToString() As String Dim ADOError As ADODB.Error Dim i As Long Dim ErrorMsg As String For Each ADOError In this.ADOErrors i = i + 1 With ADOError ErrorMsg = ErrorMsg & "Count: " & vbTab & i & vbNewLine ErrorMsg = ErrorMsg & "ADO Error Number: " & vbTab & CStr(.Number) & vbNewLine ErrorMsg = ErrorMsg & "Description: " & vbTab & .Description & vbNewLine ErrorMsg = ErrorMsg & "Source: " & vbTab & .Source & vbNewLine ErrorMsg = ErrorMsg & "NativeError: " & vbTab & CStr(.NativeError) & vbNewLine ErrorMsg = ErrorMsg & "HelpFile: " & vbTab & .HelpFile & vbNewLine ErrorMsg = ErrorMsg & "HelpContext: " & vbTab & CStr(.HelpContext) & vbNewLine ErrorMsg = ErrorMsg & "SQLState: " & vbTab & .SqlState & vbNewLine End With Next ErrorsToString = ErrorMsg & vbNewLineEnd FunctionPublic Function GetError(ByRef ADOErrors As ADODB.Errors, ByVal Index As Variant) As ADODB.Error Set GetError = ADOErrors.item(Index)End FunctionPrivate Sub PopulateOutPutParameters(ByRef Parameters As ADODB.Parameters) Dim Param As ADODB.Parameter Set this.OuputParameters = New Collection For Each Param In Parameters Select Case Param.Direction Case adParamInputOutput this.OuputParameters.Add Param Case adParamOutput this.OuputParameters.Add Param Case adParamReturnValue this.OuputParameters.Add Param End Select NextEnd Sub
1 Answer1
\$\begingroup\$\$\endgroup\$
CommandTimeout:
Allowing the client to specify a given command's execution time threshold by making it a read/write property is good improvement from the first post of this class, that you did not mention in your"outline of what I have done and why", so I am mentioning it here.
Public Property Get CommandTimeout() As Long CommandTimeout = this.CommandTimeoutEnd PropertyPublic Property Let CommandTimeout(ByVal value As Long) this.CommandTimeout = valueEnd PropertyManaging The Connection Object:
Since I am on the topic of things you forgot to mention, In both ofGetDisconnectedRecordset andQuickExecuteNonQuery, you wrote this:
If Not CurrentConnection Is Nothing Then: If (CurrentConnection.State And adStateOpen) = adStateOpen Then CurrentConnection.CloseSet CurrentConnection = NothingBit-wise comparisons, specifically with respect to theConnection object's state, is good, but you could probably make the code look more friendly:
If Not CurrentConnection Is Nothing Then If (CurrentConnection.State And adStateOpen) = adStateOpen Then CurrentConnection.Close End IfEnd IfSet CurrentConnection = NothingOutPut Parameters:
"Also, If output parameters are used, you need a way to return them, so I use the following in ADODBWrapper to do so"
You are indeed able to return parameters, from yourOuputParameters property, in the sense that you are returning the ACTualParameter object, but why do that if you only want to access a parameter's value? As you have it now, one would have to write code like the following, just to get a value:
Private Sub GetOutputParams() Dim SQLDataAdapter As ADODBWrapper Dim rsDisConnected As ADODB.Recordset Dim InputParam As String Dim OutPutParam As Integer Set SQLDataAdapter = New ADODBWrapper SQLDataAdapter.DeriveParameterDirection = True On Error GoTo CleanFail InputParam = "Val1,Val2,Val3" Set rsDisConnected = SQLDataAdapter.GetDisconnectedRecordSet(CONN_STRING, adUseClient, _ "SCHEMA.SOME_STORED_PROC_NAME", _ adCmdStoredProc, InputParam, OutPutParam) Sheet1.Range("A2").CopyFromRecordset rsDisConnected '*************************************************** 'set the parameter object only to return the value? Dim Param As ADODB.Parameter If SQLDataAdapter.OuputParameters.Count > 0 Then Set Param = SQLDataAdapter.OuputParameters(1) Debug.Print Param.Value End If '***************************************************CleanExit: Exit SubCleanFail: If SQLDataAdapter.HasADOError Then Debug.Print SQLDataAdapter.ErrorsToString() Resume CleanExitEnd SubIf you change the privatePopulateOutPutParameters procedure InADODBWrapper to add only theParameter.Value toOutPutParameters collection like this:
Private Sub PopulateOutPutParameters(ByRef Parameters As ADODB.Parameters) Dim Param As ADODB.Parameter Set this.OuputParameters = New Collection For Each Param In Parameters Select Case Param.Direction Case adParamInputOutput this.OuputParameters.Add Param.value Case adParamOutput this.OuputParameters.Add Param.value Case adParamReturnValue this.OuputParameters.Add Param.value End Select NextEnd SubThen you could do this in the client code:
If SQLDataAdapter.OuputParameters.Count > 0 Then Debug.Print SQLDataAdapter.OuputParameters(1)End IfSaying all of that, it would still be nice to have a way to map parameters without the client having to know their ordinal position as determined by the way a stored procedure was written, but this is much easier said than done.
You mustlog in to answer this question.
Explore related questions
See similar questions with these tags.