Creating an object oriented model in VBA using COM and ADODB from 2 depended SQL tables

Question

The story...

A bit of background info and how is the database designed...

Please notice you don't really have to rebuild the tables in SQL but I shared an SQL Fiddle just in case and screenshots¹ of what the database looks like. I thought it was going to be easier to explain the story of what I am doing + you can always quickly build your own if you wanted to.

So the tables look like:

enter image description here

The PART table basically stores all Parts. The PARTARC is a table that stores relationships.

In this scenario a more logical explanation of what PARTARC actually represents would be:

• PART1 is a complete KIT and includes:
  • PART2 (a LEFT-HAND model)
  • PART5 (a RIGHT-HAND model)
  • PART3 (a LABEL/STICKER)
• PART2 is a left-hand model made up of 2 components
  • PART4 (a B (Buy) type component)
  • PART6 (a B (Buy) type component)
• PART3 is just a sticker/label. The M type means it's made at the factory.
• PART4 is a low-level component of B type.
• PART5 is what PART2 really is but the RIGHT-HAND model, made up of
  • PART4 (a B (Buy) type component)
  • PART6 (a B (Buy) type component)
• PART6 is a low-level component of B type.

The point here is that PART1 is the top-level assembly part and it's made up of other components like for example PART2 or PART5 which are of type M which means they can also be made and sold separately as top-level assemblies. The B means that the part is not sold separately and can't be a top level assembly - this is why you shouldn't (will not) find the B type parts in column A on spreadsheet.

Hope this is now all clear.

The goal...

To build an object oriented data structure off of the tables and populate the spreadsheet in a very specific way.

The goal is to print out all Parent parts followed by their Children relationship to spreadsheet in a very specific format shown below. (click the image for full resolution):

enter image description here

Note: the prices may seem illogical as PART1 is made up of other more expensive parts but it's final price is quite low. Please ignore that fact, it's completely irrelevant in the scenario. The Price column's purpose is only to have an extra property on the PART class.

Current solution

I have created my own COM library to hide the connection string details form the end user. Basically, it comes down to attaching references to my .tlb, creating an instance of the COM class and returning an active ADODB.Connection to by calling cnWrapper.GetConnection.

VBA Project structure:

enter image description here

Module1 - Engine

Option Explicit
Private cn As ADODB.Connection ' global due to being passed around
Sub Main()
 Dim cnWrapper As ConnectionExt ' COM
 Set cnWrapper = New ConnectionExt ' COM
 Set cn = cnWrapper.GetConnection ' Gets an active ADODB.Connection
 ' if sucessfully connected then
 If (cn.State And adStateOpen) = adStateOpen Then
 Dim c As Parts
 Set c = New Parts
 BuildTheCollection c
 If Not IsEmpty([A1]) Then Cells.Delete ' clear spreadsheet
 PrintTheCollection c, 1 ' being called resursively
 AddAndFormatHeaders ' can't be called from PrintTheCollection due to recursitivity
 End If
 If Not (cn Is Nothing) Then
 If (cn.State And adStateOpen) = adStateOpen Then
 cn.Close
 Set cn = Nothing
 End If
 Set cnWrapper = Nothing
 End If
End Sub
Private Sub BuildTheCollection(c As Parts)
 Dim rs As ADODB.Recordset
 Set rs = New ADODB.Recordset
 On Error GoTo AllPartsHandler
 ' grab all the M type parts
 rs.Open Queries.AllParts, cn, adOpenStatic, adLockOptimistic
 ' iterate the recordset and build the OO structure
 While Not rs.EOF
 ' returns and adds to Parts collection a new Part instance based on the PartId
 c.Add CreatePart(rs(0))
 rs.MoveNext
 Wend
AllPartsHandler:
 Debug.Print IIf(Len(Err.Description) > 0, "All Parts Query Handler says: " & Err.Description, vbNullString)
 If Not (rs Is Nothing) Then
 If (rs.State And adStateOpen) = adStateOpen Then
 rs.Close
 Set rs = Nothing
 End If
 End If
 Exit Sub
End Sub
Function CreatePart(Id As Long, Optional theParent As Part) As Part
 Dim rs As ADODB.Recordset
 Set rs = New ADODB.Recordset
 On Error GoTo SinglePartHandler
 rs.Open Queries.FromPartId(Id), cn, adOpenStatic, adLockOptimistic
 Dim p As Part
 Set p = New Part
 If Not theParent Is Nothing Then
 Set p.Parent = theParent
 Else
 Set p.Parent = p
 p.IsRoot = True
 End If
 p.Id = rs(0)
 p.T = rs(1)
 p.Name = rs(2)
 p.Price = rs(3)
 Set p.Children = GetChildren(p)
 If Not (rs Is Nothing) Then
 If (rs.State And adStateOpen) = adStateOpen Then
 rs.Close
 Set rs = Nothing
 End If
 End If
 Set CreatePart = p
 Exit Function
SinglePartHandler:
 Debug.Print IIf(Len(Err.Description) > 0, "Single Part Query Handler says: " & Err.Description, vbNullString)
 If Not (rs Is Nothing) Then
 If (rs.State And adStateOpen) = adStateOpen Then
 rs.Close
 Set rs = Nothing
 End If
 End If
End Function
Function GetChildren(ByRef p As Part) As Parts
 Dim rs As ADODB.Recordset
 Set rs = New ADODB.Recordset
 On Error GoTo ChildrenHandler
 rs.Open Queries.Sons(p.Id), cn, adOpenStatic, adLockOptimistic
 Dim c As Parts
 Set c = New Parts
 On Error GoTo ChildrenHandler
 ' if has children , check and then add them
 If rs.RecordCount > 0 Then
 While Not rs.EOF
 Dim newPart As Part
 Set newPart = CreatePart(rs(0), p)
 c.Add newPart
 rs.MoveNext
 Wend
 End If
 If Not (rs Is Nothing) Then
 If (rs.State And adStateOpen) = adStateOpen Then
 rs.Close
 Set rs = Nothing
 End If
 End If
 Set GetChildren = c
 Exit Function
ChildrenHandler:
 Debug.Print IIf(Len(Err.Description) > 0, "Children Query Handler says: " & Err.Description, vbNullString)
 If Not (rs Is Nothing) Then
 If (rs.State And adStateOpen) = adStateOpen Then
 rs.Close
 Set rs = Nothing
 End If
 End If
End Function

Module2 - Printer

Option Explicit
Sub PrintTheCollection(c As Parts, Optional depth As Long)
Application.ScreenUpdating = False
 Dim p As Part
 For Each p In c
 If p.IsRoot Then
 Dim row As Long
 row = Range("A" & Rows.Count).End(xlUp).row + 1
 Range("A" & row) = p.Name
 Range("B" & row) = p.T
 Range("C" & row) = p.Price
 If p.Children.Count > 0 Then
 PrintTheCollection p.Children
 End If
 Else
 row = Range("A" & Rows.Count).End(xlUp).row
 Dim column As Long
 column = Cells(row, Columns.Count).End(xlToLeft).column + 1
 Cells(row, column) = p.Name
 Cells(row, column + 1) = p.T
 Cells(row, column + 2) = p.Price
 Cells(row, column + 3) = p.Parent.Name
 If p.Children.Count > 0 Then
 PrintTheCollection p.Children
 End If
 End If
 Next
Application.ScreenUpdating = True
End Sub
Sub AddAndFormatHeaders(Optional trigger As Boolean)
Application.ScreenUpdating = False
 'add headers
 [A1] = "PART NAME"
 [b1] = "TYPE"
 [c1] = "PRICE"
 [d1] = [A1]
 [e1] = [b1]
 [f1] = [c1]
 [g1] = "PARENT"
 Dim i As Long, j As Long
 ' the cells are deleted and there will be no user input on the sheet
 ' so usedRange.Columns.Count will always be fine here
 For i = 8 To ActiveSheet.UsedRange.Columns.Count Step 4
 For j = 0 To 3
 Cells(1, i + j) = Cells(1, j + 4)
 Next
 Next
 With ActiveWindow
 .SplitColumn = 0
 .SplitRow = 1
 End With
 ActiveWindow.FreezePanes = True
 Columns.AutoFit
Application.ScreenUpdating = True
End Sub

Part class

Public Id As Long
Public IsRoot As Boolean
Public Name As String
Public T As String ' * 1 <- yeah, I wish there was a Char type
Public Price As Double
Public Parent As Part
Public Children As Parts
Private Sub Class_Initialize()
 Set Children = New Parts
End Sub
Private Sub Class_Terminate()
 Set Children = Nothing
End Sub

Parts Collection Class (any TextEditor -> save to .cls -> import file into VBA Project

VERSION 1.0 CLASS
BEGIN
 MultiUse = -1 'True
END
Attribute VB_Name = "Parts"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private c As Collection
Private Sub Class_Initialize()
 Set c = New Collection
End Sub
Private Sub Class_Terminate()
 Set c = Nothing
End Sub
Public Sub Add(ByVal ItemToAdd As Part
 c.Add ItemToAdd
 End Sub
Public Property Get Item(index As Long) As Part
Attribute Item.VB_UserMemId = 0
 Set Item = c.Item(index)
End Property
Public Property Get NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
 Set NewEnum = c.[_NewEnum]
End Property
Public Property Get Count() As Long
 Count = c.Count
End Property

Queries static class -> Txt Editor -> save .cls -> import file VBA

VERSION 1.0 CLASS
BEGIN
 MultiUse = -1 'True
END
Attribute VB_Name = "Queries"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Option Explicit
Public Function AllParts() As String
 AllParts = "SELECT PART.PartId as 'PART ID' , " & _
 " PART.Type as 'TYPE' , " & _
 " PART.Name as 'PART NAME', " & _
 " PART.Price as 'PRICE' " & _
 "FROM " & _
 " PART " & _
 "WHERE " & _
 " PART.Type = 'M' "
End Function
Public Function FromPartId(Id As Long) As String
 FromPartId = "SELECT PART.PartId as 'PART ID' , " & _
 " PART.Type as 'TYPE' , " & _
 " PART.Name as 'PART NAME', " & _
 " PART.Price as 'PRICE' " & _
 "FROM " & _
 " PART " & _
 "WHERE " & _
 " PART.PartId = " & Id & " "
End Function
Public Function Sons(Id As Long)
 Sons = "SELECT PARTARC.Son " & _
 "FROM " & _
 " PARTARC " & _
 " left join PART on PART.PartId = PARTARC.Son " & _
 "WHERE " & _
 " PARTARC.Part = " & Id
End Function

Concerns:

• Is the CreatePart() function in Module1 a sign of bad encapsulation? Shouldn't it be a part of Part class? I was debating that for a long time but ended up doing it the way shown above. If I wanted to make this a member of Part class I would have to make Part static or have a spare, free-floating instance of Part hanging around - and I didn't want to do that. If you can think of a better approach I would love to hear about it.

• Error handling... I not sure I am doing it correctly. I have been encountering tons of errors before I tied everything up and have had at least 10 different ways to handle different errors. Once I started getting rid of some of the errors and I knew the exact reason an error occurred I assumed (rather safely) that some of them will not happen again I removed extra handlers.

• Tested the code in a real life situation with 2K parts in the PART table and over 30K in the PARTARC. In my case the code built up the collection in about the same time it was printing it to the spreadsheet (30 seconds & 30 seconds) - therefore if there is anything I have missed or could be improved to speed things up a bit I would really appreciate your advices.

• Speed, efficiency, general approach etc.. Any tips, improvements are very welcome.

One thing though - please pretend my variable named c has a proper, more suitable name. That c for Collection is like i in a for loop for me ;)

• user28366: I realize this is quite long and requires a lot of time to review so I will offer a bounty of a 100 points as soon as I can - which is 2 days:)
• Phrancis: This is a really nicely asked question! Kudos on the images and thorough explanation, and the bounty is the cherry on the cake!
• 200_success: Are you using MySQL, and is the choice of database negotiable?
• user28366: @200_success No. I am using an SQL Server.

Answer 1

Anytime you run SQL queries in a loop, where the number of queries scales according to the amount of data you have, performance is likely to be poor. Ideally, you should be able to fetch all the data you need using a fixed number of queries.

Essentially, what you are trying to do is a depth-first tree traversal, where the tree is represented by an adjacency list. There is an MSDN article on that topic, with a similar example.

A query to fetch the tree, adapted to your problem, could look like this:

WITH Parts (Path, ParentName, PartId, Type, Name, Price) AS (
 SELECT FORMAT(PartId, 'X8'), CAST(NULL AS VARCHAR), PartId, Type, Name, Price
 FROM PART
 WHERE Type = 'M'
 UNION ALL
 SELECT CONCAT(Parent.Path, '/', FORMAT(Child.PartId, 'X8')), Parent.Name, Child.PartId, Child.Type, Child.Name, Child.Price
 FROM
 Parts AS Parent
 INNER JOIN PARTARC
 ON Parent.PartId = PARTARC.Part
 INNER JOIN PART AS Child
 ON PARTARC.Son = Child.PartId
)
SELECT Name, Type, Price, ParentName
 FROM Parts
 ORDER BY Path;

The results would look like:

| Name | Type | Price | ParentName |
|-------|------|-------|------------|
| PART1 | M | 4.5 | (null) |
| PART2 | M | 12.78 | PART1 |
| PART4 | B | 7.86 | PART2 |
| PART6 | B | 7.55 | PART2 |
| PART3 | M | 2.45 | PART1 |
| PART5 | M | 17.9 | PART1 |
| PART4 | B | 7.86 | PART5 |
| PART6 | B | 7.55 | PART5 |
| PART2 | M | 12.78 | (null) |
| PART4 | B | 7.86 | PART2 |
| PART6 | B | 7.55 | PART2 |
| PART3 | M | 2.45 | (null) |
| PART5 | M | 17.9 | (null) |
| PART4 | B | 7.86 | PART5 |
| PART6 | B | 7.55 | PART5 |

It should be easy to convert that table into the desired layout with a little bit of VB. Proceeding tuple by tuple, anytime you encounter a NULL for the ParentName, start a new row in the spreadsheet; otherwise, append four columns to the current row. Of course, you can populate the in-memory data structure with that information as you go.

• user28366: OMG, that's it! :) that query is ... beautiful - why didn't I think of getting the query right from the start? gosh..sometimes it's so easy to overlook a very simple solution

Answer 2

• Bitwise conditionals make no sense to the "average" VBA dev. I like that you left a comment here, but consider leaving an remark that the check is done bitwise.

  ' if sucessfully connected then
  If (cn.State And adStateOpen) = adStateOpen Then
  

• I know you asked us not to bash on your use of c for collection, and I honestly don't mind it in your custom Parts collection class, but I really don't like your use of it here in Module1.

   Dim c As Parts
   Set c = New Parts
   BuildTheCollection c
   If Not IsEmpty([A1]) Then Cells.Delete ' clear spreadsheet
   PrintTheCollection c, 1 ' being called resursively
  

  Have you ever tried doing a Ctl+H to replace a single letter variable name? (Hint: Don't hit "replace all" when doing so.)

• PrintTheCollection could have a better name, but I'm more concerned that you have to pass it a 1 here in your Main routine. I would make the argument optional and default to one. It makes it a little cleaner and removes the need for the comment here.

• Are you sure you're cleaning up as you intend to?

  If Not (cn Is Nothing) Then
   If (cn.State And adStateOpen) = adStateOpen Then
   cn.Close
   Set cn = Nothing
   End If
   Set cnWrapper = Nothing
  End If
  

  I would think that you would want to set the connection to Nothing whether or not it was open. Also, calling .Close on an already closed connection does no harm, so I'm not real sure why you're checking it's adState. I feel like this would be simpler.

  If Not (cn Is Nothing) Then
   cn.Close
   Set cn = Nothing
   Set cnWrapper = Nothing
  End If
  

• This code also seems to show up a lot in what you've shown us here. So, first dry it up by writing a subroutine to take care of the clean up.

• Actually, this code shows up a lot in Error Handlers. Would it be simpler to just let the error bubble up and handle the clean up from your Sub Main? I would consider it. I feel like you've left a lot of places where the global connection could get closed, but then the code just keeps chugging along like it still has a valid connection.

• What is p.T again??? A part property of some kind or other. ;)

  p.T = rs(1)
  

• I like your Queries class. A lot. I do question whether it actually needs to be a class though. It seems that a standard module would work fine, but perhaps you're doing this to hide the functions from Excel's formula bar?? If that's the case, I like it even more.

• I'm not saying it's necessarily better, but I think maybe Part could a Type instead of a Class. It doesn't really do anything. It's just a collection of values, which is what Types are for. Just something to ponder on.

• RubberDuck: I didn't have time to really dig deep. I honestly didn't make it passed Module1, but hopefully it helps a little bit.
• Mathieu Guindon: Type isn't as flexible as one would think. It can't be passed around the way a "normal" value can; IMO making it a class is the correct thing to do.
• RubberDuck: Obviously I'm not saying it should be a type, just that it should be considered. I'm curious what you mean about not being able to pass it around though.
• Mathieu Guindon: Nevermind, I meant this for public UDT's defined in class modules. Should be ok if the type is public and defined in a standard code module.
• user28366: ++ The reason for bitwise checking is touched on here. The PrintTheCollection is rather what the Sub does so I think that name exactly matches what it's doing. I like the comment about the optional 1 - yeah, I missed that. Cleaning up the cn is done properly due to having a COM wrapper for it. I only want to close it in VBA if it's still open. I mean this is quite difficult to explain but I am handling it all from COM if it fails at any point. Good point about DRYing the closing of rs and cn. The p.T = part.Type

Answer 3

Private cn As ADODB.Connection ' global due to being passed around

Well that is one confusing comment. The visibility of cn is Private, its scope is therefore restricted to Module1. Was it globally scoped (with a Public, or the deprecated Global access modifier) in a previous version? I like that the comment says why, but the wording is confusing. Consider:

Private cn As ADODB.Connection ' module-level due to being passed around

Actually this comment is also a lie - the connection isn't passed around, but I'll get back to that.

---

Another comment caught my eye:

Set cn = cnWrapper.GetConnection ' Gets an active ADODB.Connection

If cnWrapper.GetConnection is returning an active ADODB.Connection, then why bother doing this?

' if sucessfully connected then
If (cn.State And adStateOpen) = adStateOpen Then

If the COM-visible managed (.net) code returned an active/open connection or Nothing, then the VBA client code wouldn't need to be bothered with adState enums, and the Main procedure could either return early (for a silent fail.. not good), or better, blow up with an object variable not set error, that should be handled in an error-handling subroutine.

---

I'm not sure I like this whole idea of using a COM-visible class library to "hide" connection string details to VBA code.

I like to consider ADODB.Connection objects like I do IDisposable implementations in .net - the object that's creating it should be responsible for cleaning it up... and that's not what you're doing here: you're creating an ADODB.Connection in a place that is only making maintenance harder than it needs to be. The day the SQL instance or connection provider changes, you have a lot of work ahead of you.

And the connection string isn't really hidden from the client:

Dim topSecretConnectionString = cn.ConnectionString
Debug.Print topSecretConnectionString

Anyone that can access the code can also access the connection string.

Unless it's the connection that you hide from the client VBA code, there's no much gain with the COM-visible library approach.

I believe there's a potential performance gain in using parameterized queries instead of concatenating the values into the WHERE clause:

Public Function FromPartId() As String
 FromPartId = "SELECT PART.PartId as 'PART ID' , " & _
 " PART.Type as 'TYPE' , " & _
 " PART.Name as 'PART NAME', " & _
 " PART.Price as 'PRICE' " & _
 "FROM " & _
 " PART " & _
 "WHERE " & _
 " PART.PartId = ?"
End Function
Public Function Sons() As String
 Sons = "SELECT PARTARC.Son " & _
 "FROM " & _
 " PARTARC " & _
 " left join PART on PART.PartId = PARTARC.Son " & _
 "WHERE " & _
 " PARTARC.Part = ?"
End Function

I noticed the Sons function returned an implicit Variant - I've made it an explicit String here. Obviously when you're using parameters like this, you can't just populate a Recordset, you need a parameterized Command. Here's how I've solved this problem:

SqlCommand

Here is a simplified version that only exposes the members that take an ADODB.Connection parameter:

VERSION 1.0 CLASS
BEGIN
 MultiUse = -1 'True
END
Attribute VB_Name = "SqlCommand"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Option Explicit
Private Type TSqlCommand
 Converter As New AdoValueConverter
 connString As String
 ResultFactory As New SqlResult
End Type
Private this As TSqlCommand
Public Function Create(ByVal connString As String) As SqlCommand
 Dim result As New SqlCommand
 result.ConnectionString = connString
 Set Create = result
End Function
Public Property Get ConnectionString() As String
 ConnectionString = this.connString
End Property
Public Property Let ConnectionString(ByVal value As String)
 this.connString = value
End Property
Public Property Get ParameterFactory() As AdoValueConverter
Attribute ParameterFactory.VB_Description = "Gets an object that can create ADODB Parameters and configure how ADODB Parameters are created."
 Set ParameterFactory = this.Converter
End Property
Public Function Execute(connection As ADODB.connection, ByVal sql As String, ParamArray parameterValues()) As ADODB.Recordset
Attribute Execute.VB_Description = "Returns a connected ADODB.Recordset that contains the results of the specified parameterized query."
'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(connection As ADODB.connection, ByVal sql As String, ParamArray parameterValues()) As Boolean
Attribute ExecuteNonQuery.VB_Description = "Returns a Boolean that indicates whether the specified parameterized SQL command (update, delete, etc.) executed without throwing an error."
'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 SelectSingleValue(connection As ADODB.connection, ByVal sql As String, ParamArray parameterValues()) As Variant
Attribute SelectSingleValue.VB_Description = "Returns the value of the first field of the first record of the results of the specified parameterized SQL query."
'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(connection As ADODB.connection, ByVal cmdType As ADODB.CommandTypeEnum, ByVal sql As String, parameterValues() As Variant) As ADODB.Command
 Dim cmd As New ADODB.Command
 cmd.ActiveConnection = connection
 cmd.CommandType = cmdType
 cmd.CommandText = sql
 Dim i As Integer
 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(this.Converter, "To" & TypeName(value) & "Parameter", VbMethod, value, ADODB.ParameterDirectionEnum.adParamInput)
 Set ToSqlInputParameter = result
End Function
Private Function ExecuteInternal(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(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 SelectSingleValueInternal(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

AdoValueConverter

This class makes creating ADODB parameters literally automagic, so the SqlCommand's clients can just pass in whatever parameters they need:

VERSION 1.0 CLASS
BEGIN
 MultiUse = -1 'True
END
Attribute VB_Name = "AdoValueConverter"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
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
Attribute OptionAllStrings.VB_Description = "Gets or sets a value that indicates whether parameters are to be treated as strings, regardless of the type."
 OptionAllStrings = mappings.OptionAllStrings
End Property
Public Property Let OptionAllStrings(ByVal value As Boolean)
 mappings.OptionAllStrings = value
End Property
Public Property Get OptionMapGuidStrings() As Boolean
Attribute OptionMapGuidStrings.VB_Description = "Gets or sets a value that indicates whether to map a string that matches a GUID pattern as a GUID parameter."
 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 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 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 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 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 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 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 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 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 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 New ADODB.Parameter
 With result
 .Type = mappings.DateMap
 .direction = direction
 .value = dateValue
 End With
 Set ToDateParameter = result
End Function

---

With the above 2 classes, you can write parameterized queries without bloating up your code:

Function CreatePart(Id As Long, Optional theParent As Part) As Part
 Dim rs As ADODB.Recordset
 On Error GoTo SinglePartHandler
 Set rs = SqlCommand.Execute(cn, Queries.FromPartId, Id)
 '...

Function GetChildren(ByRef p As Part) As Parts
 Dim rs As ADODB.Recordset
 On Error GoTo ChildrenHandler
 Set rs = SqlCommand.Execute(cn, Queries.Sons, p.Id)
 '...

---

Note that CreatePart(Id As Long ...) passes the Id value ByRef implicitly; I doubt this is intentional, the value should be passed ByVal.

Also the indentation under On Error GoTo instructions isn't consistent; GetChildren has On Error GoTo ChildrenHandler twice, but only the 2nd instance indents the code underneath. I wouldn't add an indentation level after On Error instructions.

---

The Part class severely breaks encapsulation, by exposing public fields:

Public Id As Long
Public IsRoot As Boolean
Public Name As String
Public T As String ' * 1 <- yeah, I wish there was a Char type
Public Price As Double
Public Parent As Part
Public Children As Parts

Either properly encapsulate the fields and expose properties, or go with @RubberDuck's last suggestion and create a Public Type Part in a standard code module.

The Parts class doesn't seem to be doing much either - it's basically an add-only Collection. Why not just use a Collection? Why go through all this trouble just to prevent removing items? A variable named parts As New Collection would fit the bill just fine I find (note: not c, wink-wink).

• user28366: topSecretConnectionString is not exposing your username nor password. I am not sure I understand your point about If (cn.State And adStateOpen) = adStateOpen Then... The connection is Active at the time of assignment but since the original code takes say about 10 minutes to fully execute it's rather a good idea to check if the connection is still open. The approach with the sqlCommand is very interesting I am definitely digging that deeper :) Part needs to be a class due to getters/setters validation (In my real project). Thanks for your review @Mat's Mug