Automagic & Secure ADODB

Posted on Posted in VBA \ Excel Tagged with , ,

VitoshAcademy has the pleasure to welcome its first guest author – Mr. Mathieu Guindon.  He is the project manager behind Rubberduck – an open-source COM add-in project written in C#, extending the glorious VBE with modern-day IDE features.  On Code Review and Stack Overflow he is closely monitoring the  tag. Ex-moderator on Code Review  (2015-2018), Microsoft Excel MVP (2018). See this 5 question interview with Mathieu here.

One quite common mistake many developers do every day, often without even realizing, is to write code like this:

Dim sql As String
sql = "SELECT Value FROM SomeTable WHERE Foo = '" & pFoo & "' AND Bar = " & pBar

Where pFoo is some String value, and pBar is some number. Concatenating the WHERE clause values like this, regardless of the language, leaves the code wide open to an SQL injection attack. If you hand-wave the issue and pretend it doesn’t apply to you, then you are not understanding the problem.

This vulnerability will invariably cause issues at one point or another – if you’re doing PHP or server-side C# or VB.NET, you need to see this classic XKCD comic:

If you’re writing some in-house desktop application in Java, C#, or VBA, you’ll be writing code to work around the vulnerability (e.g. double up single quotes), and think you’re covered and Mrs. Null and Mr.O’Neil can safely use your application. Until something else breaks, or until you need to maintain these concatenated SQL monstrosities in any way.

Of course there’s a better way. People will tell you to use parameterized queries instead of concatenating your values and properly accounting for single quotes. You’ve done it once or twice, thought something along the lines of “boy that’s a lot of code for so little benefit”, and went back to your old ways. Or, you’re now a convert and use parameters all the time, and you copy/paste big chunks of boilerplate code every time.

What if there was a magic way to deal with all the boilerplate?

Generating ADODB Parameters on the fly

What we need is a class that’s able to take a value, determine its type, and spit out a properly-configured ADODB.Parameter object for us. Enter AdoValueConverter:

Private Type TypeMappings
  OptionAllStrings As Boolean
  OptionMapGuidString As Boolean
  StringDateFormat As String
  BooleanMap As ADODB.DataTypeEnum
  StringMap As ADODB.DataTypeEnum
  GuidMap As ADODB.DataTypeEnum
  DateMap As ADODB.DataTypeEnum
  ByteMap As ADODB.DataTypeEnum
  IntegerMap As ADODB.DataTypeEnum
  LongMap As ADODB.DataTypeEnum
  DoubleMap As ADODB.DataTypeEnum
  SingleMap As ADODB.DataTypeEnum
  CurrencyMap As ADODB.DataTypeEnum
End Type

Private mappings As TypeMappings
Option Explicit

Private Sub Class_Initialize()

  mappings.OptionAllStrings = False
  mappings.OptionMapGuidString = True
  mappings.StringDateFormat = "yyyy-MM-dd"

  mappings.BooleanMap = adBoolean
  mappings.ByteMap = adInteger
  mappings.CurrencyMap = adCurrency
  mappings.DateMap = adDate
  mappings.DoubleMap = adDouble
  mappings.GuidMap = adGUID
  mappings.IntegerMap = adInteger
  mappings.LongMap = adInteger
  mappings.SingleMap = adSingle
  mappings.StringMap = adVarChar

End Sub

Public Property Get OptionAllStrings() As Boolean
  OptionAllStrings = mappings.OptionAllStrings
End Property

Public Property Let OptionAllStrings(ByVal value As Boolean)
  mappings.OptionAllStrings = value
End Property

Public Property Get OptionMapGuidStrings() As Boolean
  OptionMapGuidStrings = mappings.OptionMapGuidString
End Property

Public Property Let OptionMapGuidStrings(ByVal value As Boolean)
  mappings.OptionMapGuidString = value
End Property

Public Property Get StringDateFormat() As String
  StringDateFormat = mappings.StringDateFormat
End Property

Public Property Let StringDateFormat(ByVal value As String)
  mappings.StringDateFormat = value
End Property

Public Property Get BooleanMapping() As ADODB.DataTypeEnum
  BooleanMapping = mappings.BooleanMap
End Property

Public Property Let BooleanMapping(ByVal value As ADODB.DataTypeEnum)
  mappings.BooleanMap = value
End Property

Public Property Get ByteMapping() As ADODB.DataTypeEnum
  ByteMapping = mappings.ByteMap
End Property

Public Property Let ByteMapping(ByVal value As ADODB.DataTypeEnum)
  mappings.ByteMap = value
End Property

Public Property Get CurrencyMapping() As ADODB.DataTypeEnum
  CurrencyMapping = mappings.CurrencyMap
End Property

Public Property Let CurrencyMapping(ByVal value As ADODB.DataTypeEnum)
  mappings.CurrencyMap = value
End Property

Public Property Get DateMapping() As ADODB.DataTypeEnum
  DateMapping = mappings.DateMap
End Property

Public Property Let DateMapping(ByVal value As ADODB.DataTypeEnum)
  mappings.DateMap = value
End Property

Public Property Get DoubleMapping() As ADODB.DataTypeEnum
  DoubleMapping = mappings.DoubleMap
End Property

Public Property Let DoubleMapping(ByVal value As ADODB.DataTypeEnum)
  mappings.DoubleMap = value
End Property

Public Property Get GuidMapping() As ADODB.DataTypeEnum
  GuidMapping = mappings.GuidMap
End Property

Public Property Let GuidMapping(ByVal value As ADODB.DataTypeEnum)
  mappings.GuidMap = value
End Property

Public Property Get IntegerMapping() As ADODB.DataTypeEnum
  IntegerMapping = mappings.IntegerMap
End Property

Public Property Let IntegerMapping(ByVal value As ADODB.DataTypeEnum)
  mappings.IntegerMap = value
End Property

Public Property Get LongMapping() As ADODB.DataTypeEnum
  LongMapping = mappings.LongMap
End Property

Public Property Let LongMapping(ByVal value As ADODB.DataTypeEnum)
  mappings.LongMap = value
End Property

Public Property Get SingleMapping() As ADODB.DataTypeEnum
  SingleMapping = mappings.SingleMap
End Property

Public Property Let SingleMapping(ByVal value As ADODB.DataTypeEnum)
  mappings.SingleMap = value
End Property

Public Property Get StringMapping() As ADODB.DataTypeEnum
  StringMapping = mappings.StringMap
End Property

Public Property Let StringMapping(ByVal value As ADODB.DataTypeEnum)
  mappings.StringMap = value
End Property

Public Function ToNamedParameter(ByVal name As String, ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.parameter

  Dim result As ADODB.parameter
  Set result = CallByName(Me, "To" & TypeName(value) & "Parameter", VbMethod, value, direction)

  result.name = name
  Set ToNamedParameter = result

End Function

Public Function ToStringParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.parameter

  Dim stringValue As String
  stringValue = CStr(value)

  If Not mappings.OptionAllStrings Then
    If IsGuidString(stringValue) Then ' split on 2 conditions for performance: evaluating IsGuidString uses regular expressions
      Set ToStringParameter = ToGuidParameter(value, direction)
      Exit Function
    End If
  End If

  Dim result As ADODB.parameter
  Set result = New ADODB.parameter
  With result
    .Type = mappings.StringMap
    .direction = direction
    .size = Len(stringValue)
    .value = stringValue
  End With

  Set ToStringParameter = result

End Function

Public Function ToGuidParameter(ByVal value As String, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.parameter

  If mappings.OptionAllStrings Then
    Set ToGuidParameter = ToStringParameter(value, direction)
    Exit Function
  End If

  Dim result As ADODB.parameter
  Set result = New ADODB.parameter
  With result
    .Type = mappings.GuidMap
    .direction = direction
    .value = value
  End With

  Set ToGuidParameter = result

End Function

Private Function IsGuidString(ByVal value As String) As Boolean

  Dim regex As New RegExp
  regex.pattern = "\b[A-F0-9]{8}(?:-[A-F0-9]{4}){3}-[A-F0-9]{12}\b"

  Dim matches As MatchCollection
  Set matches = regex.Execute(UCase$(value))

  IsGuidString = matches.Count <> 0

  Set regex = Nothing
  Set matches = Nothing

End Function

Public Function ToIntegerParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.parameter

  If mappings.OptionAllStrings Then
    Set ToIntegerParameter = ToStringParameter(value, direction)
    Exit Function
  End If

  Dim integerValue As Long
  integerValue = CLng(value)

  Dim result As ADODB.parameter
  Set result = New ADODB.parameter
  With result
    .Type = mappings.IntegerMap
    .direction = direction
    .value = integerValue
  End With

  Set ToIntegerParameter = result

End Function

Public Function ToByteParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.parameter

  If mappings.OptionAllStrings Then
    Set ToByteParameter = ToStringParameter(value, direction)
    Exit Function
  End If

  Dim byteValue As Byte
  byteValue = CByte(value)

  Dim result As ADODB.parameter
  Set result = New ADODB.parameter
  With result
    .Type = mappings.ByteMap
    .direction = direction
    .value = byteValue
  End With

  Set ToByteParameter = result

End Function

Public Function ToLongParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.parameter

  If mappings.OptionAllStrings Then
    Set ToLongParameter = ToStringParameter(value, direction)
    Exit Function
  End If

  Dim longValue As Long
  longValue = CLng(value)

  Dim result As ADODB.parameter
  Set result = New ADODB.parameter
  With result
    .Type = mappings.LongMap
    .direction = direction
    .value = longValue
  End With

  Set ToLongParameter = result

End Function

Public Function ToDoubleParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.parameter

  If mappings.OptionAllStrings Then
    Set ToDoubleParameter = ToStringParameter(value, direction)
    Exit Function
  End If

  Dim doubleValue As Double
  doubleValue = CDbl(value)

  Dim result As ADODB.parameter
  Set result = New ADODB.parameter
  With result
    .Type = mappings.DoubleMap
    .direction = direction
    .value = doubleValue
  End With

  Set ToDoubleParameter = result

End Function

Public Function ToSingleParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.parameter

  If mappings.OptionAllStrings Then
    Set ToSingleParameter = ToStringParameter(value, direction)
    Exit Function
  End If

  Dim singleValue As Single
  singleValue = CSng(value)

  Dim result As ADODB.parameter
  Set result = New ADODB.parameter
  With result
    .Type = mappings.SingleMap
    .direction = direction
    .value = singleValue
  End With

  Set ToSingleParameter = result

End Function

Public Function ToCurrencyParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.parameter

  If mappings.OptionAllStrings Then
    Set ToCurrencyParameter = ToStringParameter(value, direction)
    Exit Function
  End If

  Dim currencyValue As Currency
  currencyValue = CCur(value)

  Dim result As ADODB.parameter
  Set result = New ADODB.parameter
  With result
    .Type = mappings.CurrencyMap
    .direction = direction
    .value = currencyValue
  End With

  Set ToCurrencyParameter = result

End Function

Public Function ToBooleanParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.parameter

  If mappings.OptionAllStrings Then
    Set ToBooleanParameter = ToStringParameter(value, direction)
    Exit Function
  End If

  Dim boolValue As Boolean
  boolValue = CBool(value)

  Dim result As ADODB.parameter
  Set result = New ADODB.parameter
  With result
    .Type = mappings.BooleanMap
    .direction = direction
    .value = boolValue
  End With

  Set ToBooleanParameter = result

End Function

Public Function ToDateParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.parameter

  If mappings.OptionAllStrings Then
    Set ToDateParameter = ToStringParameter(Format$(value, mappings.StringDateFormat), direction)
    Exit Function
  End If

  Dim dateValue As Date
  dateValue = CDate(value)

  Dim result As ADODB.parameter
  Set result = New ADODB.parameter
  With result
    .Type = mappings.DateMap
    .direction = direction
    .value = dateValue
  End With

  Set ToDateParameter = result

End Function

Pretty straightforward, boring boilerplate: to each type its own dedicated function. We have an option to make everything convert to a String parameter, and another to determine whether a GUID string should be converted into a Guid or a String parameter, and a Property Let member allows reconfiguring the mappings at run-time.

A more advanced implementation could perhaps use a keyed collection or a dictionary to store the mappings, instead of spelling them all out.

Next, we need another class – let’s call it SqlCommand, whose job is to take the SQL string and the parameter values, create the ADODB boilerplate, execute it, and return the results.

Private converter As New AdoValueConverter

Option Explicit

Public Property Get ParameterFactory() As AdoValueConverter
  Set ParameterFactory = converter
End Property

Public Function Execute(ByVal connection As ADODB.connection, ByVal sql As String, ParamArray parameterValues()) As ADODB.Recordset
'Returns a connected ADODB.Recordset that contains the results of the specified parameterized query.

  Dim parameters() As Variant
  parameters = parameterValues

  Set Execute = ExecuteInternal(connection, sql, parameters)

End Function

Public Function ExecuteNonQuery(ByVal connection As ADODB.connection, ByVal sql As String, ParamArray parameterValues()) As Boolean
'Returns a Boolean that indicates whether the specified parameterized SQL command (update, delete, etc.) executed without throwing an error.

  Dim parameters() As Variant
  parameters = parameterValues

  ExecuteNonQuery = ExecuteNonQueryInternal(connection, sql, parameters)

End Function

Public Function ExecuteStoredProc(ByVal connection As ADODB.connection, ByVal spName As String, ParamArray parameterValues()) As ADODB.Recordset
'Executes the specified parameterized stored procedure, passing specified parameter values.

  Dim parameters() As Variant
  parameters = parameterValues

  Set ExecuteStoredProc = ExecuteStoredProcInternal(connection, spName, parameters)

End Function

Public Function SelectSingleValue(ByVal connection As ADODB.connection, ByVal sql As String, ParamArray parameterValues()) As Variant
'Returns the value of the first field of the first record of the results of the specified parameterized SQL query.

  Dim parameters() As Variant
  parameters = parameterValues

  SelectSingleValue = SelectSingleValueInternal(connection, sql, parameters)

End Function

Private Function CreateCommand(ByVal connection As ADODB.connection, ByVal cmdType As ADODB.CommandTypeEnum, ByVal sql As String, parameterValues() As Variant) As ADODB.Command

  Dim cmd As ADODB.Command
  Set cmd = New ADODB.Command
  cmd.ActiveConnection = connection
  cmd.CommandType = cmdType
  cmd.CommandText = sql

  Dim i As Long
  Dim value As Variant

  For i = LBound(parameterValues) To UBound(parameterValues)
    value = parameterValues(i)
    If TypeName(value) <> "Variant()" Then cmd.parameters.Append ToSqlInputParameter(value)
  Next

  Set CreateCommand = cmd

End Function

Private Function ToSqlInputParameter(ByVal value As Variant) As ADODB.parameter

  If IsObject(value) Then Err.Raise vbObjectError + 911, "SqlCommand.ToSqlInputParameter", "Invalid argument, parameter value cannot be an object."

  Dim result As ADODB.parameter
  Set result = CallByName(converter, "To" & TypeName(value) & "Parameter", VbMethod, value, ADODB.ParameterDirectionEnum.adParamInput)

  Set ToSqlInputParameter = result

End Function

Private Function ExecuteInternal(ByVal connection As ADODB.connection, ByVal sql As String, parameterValues()) As ADODB.Recordset

  Dim cmd As ADODB.Command
  Set cmd = CreateCommand(connection, adCmdText, sql, parameterValues)

  Set ExecuteInternal = cmd.Execute

End Function

Private Function ExecuteNonQueryInternal(ByVal connection As ADODB.connection, ByVal sql As String, parameterValues()) As Boolean

  Dim cmd As ADODB.Command
  Set cmd = CreateCommand(connection, adCmdText, sql, parameterValues)

  Dim result As Boolean
  On Error Resume Next
  cmd.Execute
  result = (Err.Number = 0)
  On Error GoTo 0

  ExecuteNonQueryInternal = result

End Function

Private Function ExecuteStoredProcInternal(ByVal connection As ADODB.connection, ByVal spName As String, parameterValues()) As ADODB.Recordset

  Dim cmd As ADODB.Command
  Set cmd = CreateCommand(connection, adCmdStoredProc, spName, parameterValues)

  Set ExecuteStoredProcInternal = cmd.Execute

End Function

Private Function SelectSingleValueInternal(ByVal connection As ADODB.connection, ByVal sql As String, parameterValues()) As Variant

  Dim parameters() As Variant
  parameters = parameterValues

  Dim cmd As ADODB.Command
  Set cmd = CreateCommand(connection, adCmdText, sql, parameters)

  Dim rs As ADODB.Recordset
  Set rs = cmd.Execute

  Dim result As Variant
  If Not rs.BOF And Not rs.EOF Then result = rs.fields(0).value

  rs.Close
  Set rs = Nothing

  SelectSingleValueInternal = result

End Function

The magic happens in ToSqlInputParameter:

Private Function ToSqlInputParameter(ByVal value As Variant) As ADODB.parameter

  If IsObject(value) Then Err.Raise vbObjectError + 911, "SqlCommand.ToSqlInputParameter", "Invalid argument, parameter value cannot be an object."

  Dim result As ADODB.parameter
  Set result = CallByName(converter, "To" & TypeName(value) & "Parameter", VbMethod, value, ADODB.ParameterDirectionEnum.adParamInput)

  Set ToSqlInputParameter = result

End Function

Using CallByName against the converter, we invoke the appropriate To[TypeName]Parameter and receive an ADODB parameter that's ready to use with an ADODB command - and the command itself is automatically created & wired-up too.

All public methods require an ADODB connection, so you can initiate a transaction and run multiple commands before you commit. The parameters are received with a ParamArray argument, so the usage would look like this:

Const sql As String = "SELECT Value FROM SomeTable WHERE Foo = ? AND Bar = ?"
Dim conn As ADODB.Connection
Set conn = New ADODB.Connection
conn.ConnectionString = "{connection string}"
conn.Open
Dim rs As ADODB.Recordset
With New SqlCommand
  Set rs = .Execute(sql, pKey, pIndex)
End With
'...iterate recordset...
conn.Close

You could then have additional methods that wire up the connection automatically, execute the query, iterate the recordset and return a dictionary of key-value pairs for each record (works great for small result sets), and then this eliminates the connection boilerplate, too, leaving the “client code” with nothing to worry about except passing the parameter values in the correct order, and working with the query results.

You’ll never need to worry about single quotes and SQL injection ever again… and the command & parameterization boilerplate is nicely tucked away in its own dedicated and reusable class.

Related posts:

  1. VBA – Quick Renamer of files in folders with VBA
  2. VBA – Save a Chart as a Picture (Gif)
  3. VBA – Resolving C# competition problem with VBA and Excel (2)
About

I must have been 12 or 13 years old when I unearthed the old Commodore-64 from my childhood, of which I remembered not much at all, beyond Q*Bert! and Pac-Man. I was thoroughly fascinated, and quickly learned the built-in BASIC 2.0, later QBasic on a "real computer", then VB4, VB5, and VB6 in my later teens. A few years later I started my professional life with Excel and VBA (Oh wow, I can write VB6 in Excel!), then I learned about databases with Access, moved on to SQL Server, and then learned C# and the .NET framework. These days I mostly work with T-SQL, SSRS, C#, and VBA.