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\$
  • 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\$ – user28366 Nov 13 '14 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\$ – Phrancis Nov 17 '14 at 22:07
  • \$\begingroup\$ Are you using MySQL, and is the choice of database negotiable? \$\endgroup\$ – 200_success Nov 18 '14 at 0:31
  • \$\begingroup\$ @200_success No. I am using an SQL Server. \$\endgroup\$ – user28366 Nov 18 '14 at 7:59
8
+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
    \$\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\$ – user28366 Nov 18 '14 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\$
  • \$\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\$ – RubberDuck Nov 17 '14 at 22:14
  • 1
    \$\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\$ – Mathieu Guindon Nov 18 '14 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\$ – RubberDuck Nov 18 '14 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\$ – Mathieu Guindon Nov 18 '14 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\$ – user28366 Nov 18 '14 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\$
  • \$\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\$ – user28366 Nov 18 '14 at 8:35

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy