15
\$\begingroup\$

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:

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

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

3 Answers 3

Reset to default
9
+100
\$\begingroup\$

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.

\$\endgroup\$
1
  • 1
    \$\begingroup\$ 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 \$\endgroup\$ Commented Nov 18, 2014 at 9:46
6
\$\begingroup\$

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

\$\endgroup\$
6
  • \$\begingroup\$ I didn't have time to really dig deep. I honestly didn't make it passed Module1, but hopefully it helps a little bit. \$\endgroup\$ Commented Nov 17, 2014 at 22:14
  • 2
    \$\begingroup\$ 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. \$\endgroup\$ Commented Nov 18, 2014 at 1:15
  • 1
    \$\begingroup\$ 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. \$\endgroup\$ Commented Nov 18, 2014 at 1:31
  • \$\begingroup\$ 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. \$\endgroup\$ Commented Nov 18, 2014 at 1:47
  • \$\begingroup\$ ++ 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 \$\endgroup\$ Commented Nov 18, 2014 at 8:13
2
\$\begingroup\$ 
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).

\$\endgroup\$
1
  • \$\begingroup\$ 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 \$\endgroup\$ Commented Nov 18, 2014 at 8:35

You must log in to answer this question.