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 screenshots1 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:

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):

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:

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

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

End If

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

End Sub

Private Sub BuildTheCollection(c As Parts)

On Error GoTo AllPartsHandler

' grab all the M type parts

' 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

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
rs.Close
Set rs = Nothing
End If
End If
Exit Sub
End Sub

Function CreatePart(Id As Long, Optional theParent As Part) As Part

On Error GoTo SinglePartHandler

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
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
rs.Close
Set rs = Nothing
End If
End If
End Function

Function GetChildren(ByRef p As Part) As Parts

On Error GoTo ChildrenHandler

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)
rs.MoveNext
Wend
End If

If Not (rs Is Nothing) 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
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

Application.ScreenUpdating = False

[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

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 ;)

• 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:) – user28366 Nov 13 '14 at 14:29
• This is a really nicely asked question! Kudos on the images and thorough explanation, and the bounty is the cherry on the cake! – Phrancis Nov 17 '14 at 22:07
• Are you using MySQL, and is the choice of database negotiable? – 200_success Nov 18 '14 at 0:31
• @200_success No. I am using an SQL Server. – user28366 Nov 18 '14 at 7:59

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.

• 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 – user28366 Nov 18 '14 at 9:46
• 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

• 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
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.

• I didn't have time to really dig deep. I honestly didn't make it passed Module1, but hopefully it helps a little bit. – RubberDuck Nov 17 '14 at 22:14
• 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. – Mathieu Guindon Nov 18 '14 at 1:15
• 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. – RubberDuck Nov 18 '14 at 1:31
• 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. – Mathieu Guindon Nov 18 '14 at 1:47
• ++ 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 – user28366 Nov 18 '14 at 8:13
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 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
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

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."

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

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

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

Set cmd = CreateCommand(connection, adCmdText, sql, parameters)

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


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_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
End Type

Private mappings As TypeMappings
Option Explicit

Private Sub Class_Initialize()

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

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

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

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

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)

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)

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)

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)

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)

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)

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)

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)

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

On Error GoTo SinglePartHandler
Set rs = SqlCommand.Execute(cn, Queries.FromPartId, Id)

'...

Function GetChildren(ByRef p As Part) As Parts

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).

• 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 – user28366 Nov 18 '14 at 8:35