In yesterday's post, I wrote about simple DTOs in VBA.  Today, I want to talk about what I call "complex DTOs."

Simple vs. complex DTOs

As of this writing, Wikipedia states that a data transfer object:

"...does not have any behavior except for storage, retrieval, serialization and deserialization of its own data..."

With this description in mind, I use the term "simple DTO" to describe a class module whose behavior is limited to storage and retrieval of its own data. By contrast, I use the term "complex DTO" to describe a class that provides serialization and deserialization in addition to storage and retrieval of its own data.

Simple DTO example

Here is an example of a "simple" DTO.  I use the udt prefix when naming simple DTO class modules as these are really just glorified user-defined types.  I use them in lieu of the built-in UDT feature when I want to add instances of the object to a collection or dictionary (details here).

'--== Class module named:  udtCheckInfo  ==--
Option Compare Database
Option Explicit

Public TypeCode As String
Public BranchID As Long
Public IssueDate As Date

Complex DTO example

The complex DTO example has a lot more code, but the vast majority of it is boilerplate:

'--== Class module named:  dtoCheckInfo  ==--
'Data Transfer Object: CheckInfo
'Purpose:   Used to move related data between forms without affecting global state
Option Compare Database
Option Explicit

'To update this class, modify and run the following line of code from the immediate window:
'   CreateDTO "CheckInfo", "TypeCode", "String", "BranchID", "Long", "IssueDate", "Date"
'1. Maintain internal state
Private Type typThisClass
    TypeCode As String
    HasTypeCode As Boolean
    
    BranchID As Long
    HasBranchID As Boolean
    
    IssueDate As Date
    HasIssueDate As Boolean
    
End Type
Private this As typThisClass

'2. Class properties that return True only if the corresponding property value has been set
Public Property Get HasTypeCode() As Boolean: HasTypeCode = this.HasTypeCode: End Property
Public Property Get HasBranchID() As Boolean: HasBranchID = this.HasBranchID: End Property
Public Property Get HasIssueDate() As Boolean: HasIssueDate = this.HasIssueDate: End Property

'3. Class properties to return the values stored internally
Public Property Get TypeCode() As String
    If Not HasTypeCode Then Throw "TypeCode has not been assigned a value"
    TypeCode = this.TypeCode
End Property
Public Property Get BranchID() As Long
    If Not HasBranchID Then Throw "BranchID has not been assigned a value"
    BranchID = this.BranchID
End Property
Public Property Get IssueDate() As Date
    If Not HasIssueDate Then Throw "IssueDate has not been assigned a value"
    IssueDate = this.IssueDate
End Property

'4. Once a property has been set, update the corresponding Has* property accordingly
Public Property Let TypeCode(RHS As String)
    this.TypeCode = RHS
    this.HasTypeCode = True
End Property

Public Property Let BranchID(RHS As Long)
    this.BranchID = RHS
    this.HasBranchID = True
End Property

Public Property Let IssueDate(RHS As Date)
    this.IssueDate = RHS
    this.HasIssueDate = True
End Property


'5. Converts the class data into a string to be passed among Access objects via OpenArgs;
'   used to "dehydrate" the class
Public Function Serialize() As String
    Dim s As String
    
    If this.HasTypeCode Then s = Conc(s, "TypeCode=" & this.TypeCode, ";")
    If this.HasBranchID Then s = Conc(s, "BranchID=" & this.BranchID, ";")
    If this.HasIssueDate Then s = Conc(s, "IssueDate=" & this.IssueDate, ";")

    Serialize = s
End Function

'6. Extracts data from within the string and populates internal variables accordingly;
'   used to "hydrate" the class
Public Sub Deserialize(SerializedString As String)
    Dim s As String
    s = SerializedString
    
    Dim vTypeCode As Variant: vTypeCode = Parse(s, "TypeCode")
    Dim vBranchID As Variant: vBranchID = Parse(s, "BranchID")
    Dim vIssueDate As Variant: vIssueDate = Parse(s, "IssueDate")
    
    If Not IsNull(vTypeCode) Then
        this.TypeCode = vTypeCode
        this.HasTypeCode = True
    End If
    If Not IsNull(vBranchID) Then
        this.BranchID = vBranchID
        this.HasBranchID = True
    End If
    If Not IsNull(vIssueDate) Then
        this.IssueDate = vIssueDate
        this.HasIssueDate = True
    End If
End Sub

I know what you're thinking.  That's ridiculous.  We just went from 7 lines of code in udtCheckInfo to 93 lines of code in dtoCheckInfo.  Why bother?  I'm glad you asked.

Passing data to forms and reports

Sometimes there are pieces of data that we want to pass to a form or report that we are opening.  Such data can be passed via the OpenArgs argument.  There's only one problem; the OpenArgs argument is a simple string.  

The way most developers work around this limitation is to store these values within the global state.  The exact implementation may vary:

  • TempVars
  • A hidden global form
  • A global object
  • Several global variables

The problem with using global state to transfer information within an application is that your routines create side effects.  These side effects could impact other parts of your program that you don't intend to impact.  In an event-driven application, like Microsoft Access, these situations often happens only when an end-user performs some task in an unusual (and unexpected) way.  

Reproducing such bugs can be nearly impossible.  The best way to resolve them is to avoid them in the first place.  And that means avoiding making changes to global state whenever possible.

Via the Parse() function

In an earlier article, I introduced a function for passing multiple values to forms and reports using my Parse() function.  The Parse function has one major drawback, though.  It has no compile-time error checking.  

Since every piece of data is encoded and passed as a string, the danger of a typo breaking the data transfer is very real.  What's worse, that typo may not even trigger a runtime error.

For example, here's the Parse function in action.  This is the sending side...

Dim RptInfo As String

RptInfo = Conc(RptInfo, "DisplayFilter=Accounts Added This Year\nRegion = South", ";")
RptInfo = Conc(RptInfo, "ShadeAlternateRows=" & Me.chkShadeRows, ";")
RptInfo = Conc(RptInfo, "FormatForDuplex=" & Me.chkDuplex, ";")

DoCmd.OpenReport "MyReport", acViewPreview, , Criteria, , RptInfo

...and this is the receiving side (e.g., the Report_Open event)...

Dim DisplayFilter As String
DisplayFilter = Parse(Me.OpenArgs, "Display Filter", vbString)

Dim ShadeRows As Boolean
ShadeRows = Parse(Me.OpenArgs, "ShadeAlternateRows", vbBoolean)

Dim FormatForDuplex As Boolean
FormatForDuplex = Parse(Me.OpenArgs, "FormatForDuplex", vbBoolean)

These examples are taken straight from my earlier article.  Well, not exactly.  On the sending side, I changed the DisplayFilter lookup to look for a value named "Display Filter" (note the space).  But, on the sending side, that same value was encoded as "DisplayFilter" (no space).

This means when the report opens, it will fetch the "Display Filter" value from OpenArgs and return an empty string.  That's a problem.  Instead of displaying the following text in our report heading...

Accounts Added This Year
Region = South

...the human-readable filtering description will be blank.  Someone reviewing the printed report will then assume that every record in the database is shown, not just the accounts added this year from the south region.

Via complex DTOs

With a complex DTO, we can avoid this type of error by introducing support for compile-time error checking.

Here's how we would rewrite the sending and receiving code above.  First, the sending side...

Dim DTO As New dtoRptInfo
DTO.DisplayFilter = "Accounts Added This Year\nRegion = South"
DTO.ShadeAlternateRows = Me.chkShadeRows
DTO.FormatForDuplex = Me.chkDuplex

DoCmd.OpenReport "MyReport", acViewPreview, , Criteria, , DTO.Serialize

...then the receiving side...

Dim DTO As New dtoRptInfo
DTO.Deserialize Me.OpenArgs

Dim DisplayFilter As String
DisplayFilter = DTO.DisplayFilter

Dim ShadeRows As Boolean
ShadeRows = DTO.ShadeAlternateRows

Dim FormatForDuplex As Boolean
FormatForDuplex = DTO.FormatForDuplex

Benefits of the complex DTO approach

There are several benefits to this approach.  Each of these benefits can be considered a separate layer of defense in a defenses-in-depth approach to programming.

Compile-time checking

If I try to assign a value to DTO.DisplayyFilter, the extra "y" in "Display" will trigger a compile error.  When I was building a string via Parse, that sort of thing would slip right past the compiler.

IntelliSense

Along with compile-time checking, we also gain the efficiency of using IntelliSense to save ourselves some typing.  Rather than typing out "ShadeAlternateRows", we can simply type DTO.S then [Ctl] + [Space] and VBA will auto-complete the property to DTO.ShadeAlternateRows.  Did I ever mention that I love IntelliSense?

Run-time error checking

In addition to compile time error checking, the complex DTO method also gains us run-time error checking.  For example, if I try to read from the .DisplayFilter property before it's been set, the class will throw a "DisplayFilter has not been assigned a value" error.

Type safety

Besides the compile-time checking of the property names, using a complex DTO class also gains us the advantage of enforcing type checks on the properties.  Type safety gets enforced both at compile time and run time.  At compile time, VBA will balk if you try to assign the literal value Null to a Currency type for example.  At runtime, trying to convert the string "Yesterday" to a Date type will produce an error.

Drawbacks of the complex DTO approach

The biggest drawback by far is the amount of boilerplate code needed to build the DTO class.  

Signal vs. Noise

I generally avoid boilerplate code because it reduces the signal to noise ratio of our code.  However, in this case, I believe it's worth it.  The signal to noise ratio is only poor in the DTO class module itself.  Everywhere else in our codebase, using the DTO improves the signal to noise ratio and increases code readability.

Besides, I do a couple of things to mitigate the poor signal to noise ratio in the class module:

  1. I generate the DTO with a single line of code (see below)
  2. I use version control, so any minor change accidentally made to the DTO appears when I go to commit my application changes to Mercurial

Creating the class from scratch

For a DTO with only three properties, the DTO class module requires 93 lines of code.  Believing you can write that many lines of repetitive code without introducing logic errors via typos or other inconsistencies is overly optimistic, even by programmer standards.  

What you would probably do is copy and paste from a different DTO class, and then carefully try to replace each property and method with properties and methods needed for the new class.

Updating an existing DTO class

Even if you are careful when you create the class, what about when you have to modify it?  There are six different areas where you need to update the code when you introduce (or remove) a property.  Assuming you correctly update the code in all six places, that's still a tedious job that requires careful attention to detail.

But what if you didn't have to write any of those lines of code?

Generating the DTO class module from a single function call

What if--instead of having to type 93 lines of code by hand--you just had to execute the following line of code from the immediate window:

CreateDTO "CheckInfo", "TypeCode", "String", "BranchID", "Long", "IssueDate", "Date"
Generating a 93-line class module with a single function call

That's great, but what about when you need to update the DTO by adding, removing, renaming, or changing the type of one or more of the class properties?  That's easy, too!

The code generation routine also creates a comment with the procedure call needed to recreate the class module.  So, to change the DTO, you follow these simple steps:

  1. Copy the CreateDTO line from the comments at the top of the DTO class
  2. Paste the CreateDTO line into the immediate window
  3. Add, remove, or update the property name-type pairs and execute the routine

CreateDTO usage

The usage is very straightforward.  The first parameter passed is the base name of the DTO.  The routine will add the "dto" prefix when creating or updating the class module.  Feel free to use a different prefix in your own code; there is nothing special about dto, it's simply my convention.

The second "parameter" is actually a ParamArray, which will accept an infinite number of procedure arguments. After the first parameter, you simply add names and their associated types as pairs of parameters.  

For simplicity, I pass the parameter types as Strings to the CreateDTO routine.  CreateDTO is only for use during design time, so there is little benefit in having it perform compile-time checks.

The Code

Without further ado, my code is presented below.  This particular set of code builds upon several previous articles I wrote.  I'm including all of the required dependencies, with links to their corresponding articles in the code comments where appropriate.

Some notes if you're new here:

  • I don't user boilerplate error handling code because I use vbWatchdog.
  • I throw errors with regularity as part of a good defensive programming posture
  • I maintain a code library of reusable functions and procedures
  • I use a Notepad++ macro to build multi-line VBA strings
  • Until I get comments set up on this blog, you can reach me on Twitter or via email (mike {at} nolongerset {dot} com) with any questions

DesignProcedures standard code module

'Creates a Data Transfer Object class for transferring related groups of data
'   among Form and Report .OpenArgs properties via string serialization and deserialization
'See Checks program for sample implementation
'Sample usage: CreateDTO "CheckInfo", "TypeCode", "String", "BranchID", "Long", "IssueDate", "Date"
Sub CreateDTO(DtoName As String, ParamArray VarTypePairs() As Variant)
    Dim s As String, i As Long
    
    s = s & "'Data Transfer Object: " & DtoName & vbNewLine
    s = s & "'Purpose:   Used to move related data between forms without affecting global state" & vbNewLine
    s = s & "Option Compare Database" & vbNewLine
    s = s & "Option Explicit" & vbNewLine
    s = s & vbNewLine
    
    s = s & "'To update this class, modify and run the following line of code from the immediate window:" & vbNewLine
    s = s & "'   CreateDTO """ & DtoName & """"
    For i = LBound(VarTypePairs) To UBound(VarTypePairs) Step 2
        s = s & ", """ & VarTypePairs(i) & """"
        s = s & ", """ & VarTypePairs(i + 1) & """"
    Next i
    s = s & vbNewLine
    
    s = s & "'1. Maintain internal state" & vbNewLine
    s = s & "Private Type typThisClass" & vbNewLine
    For i = LBound(VarTypePairs) To UBound(VarTypePairs) Step 2
        s = s & "    " & VarTypePairs(i) & " As " & VarTypePairs(i + 1) & vbNewLine
        s = s & "    Has" & VarTypePairs(i) & " As Boolean" & vbNewLine
        s = s & "    " & vbNewLine
    Next i
    s = s & "End Type" & vbNewLine
    s = s & "Private this As typThisClass" & vbNewLine
    s = s & vbNewLine
    
    s = s & "'2. Class properties that return True only if the corresponding property value has been set" & vbNewLine
    For i = LBound(VarTypePairs) To UBound(VarTypePairs) Step 2
        s = s & "Public Property Get Has" & VarTypePairs(i) & "() As Boolean: Has" & VarTypePairs(i) & " = this.Has" & VarTypePairs(i) & ": End Property" & vbNewLine
    Next i
    s = s & vbNewLine
    
    s = s & "'3. Class properties to return the values stored internally" & vbNewLine
    For i = LBound(VarTypePairs) To UBound(VarTypePairs) Step 2
        s = s & "Public Property Get " & VarTypePairs(i) & "() As " & VarTypePairs(i + 1) & vbNewLine
        s = s & "    If Not Has" & VarTypePairs(i) & " Then Throw """ & VarTypePairs(i) & " has not been assigned a value""" & vbNewLine
        s = s & "    " & VarTypePairs(i) & " = this." & VarTypePairs(i) & vbNewLine
        s = s & "End Property" & vbNewLine
    Next i
    s = s & vbNewLine
    
    s = s & "'4. Once a property has been set, update the corresponding Has* property accordingly" & vbNewLine
    For i = LBound(VarTypePairs) To UBound(VarTypePairs) Step 2
        s = s & "Public Property Let " & VarTypePairs(i) & "(RHS As " & VarTypePairs(i + 1) & ")" & vbNewLine
        s = s & "    this." & VarTypePairs(i) & " = RHS" & vbNewLine
        s = s & "    this.Has" & VarTypePairs(i) & " = True" & vbNewLine
        s = s & "End Property" & vbNewLine
        s = s & vbNewLine
    Next i
    s = s & vbNewLine
    
    s = s & "'5. Converts the class data into a string to be passed among Access objects via OpenArgs;" & vbNewLine
    s = s & "'   used to ""dehydrate"" the class" & vbNewLine
    s = s & "Public Function Serialize() As String" & vbNewLine
    s = s & "    Dim s As String" & vbNewLine
    s = s & "    " & vbNewLine
    For i = LBound(VarTypePairs) To UBound(VarTypePairs) Step 2
        s = s & "    If this.Has" & VarTypePairs(i) & " Then s = Conc(s, """ & VarTypePairs(i) & "="" & this." & VarTypePairs(i) & ", "";"")" & vbNewLine
    Next i
    s = s & vbNewLine
    s = s & "    Serialize = s" & vbNewLine
    s = s & "End Function" & vbNewLine
    s = s & vbNewLine
    
    
    s = s & "'6. Extracts data from within the string and populates internal variables accordingly;" & vbNewLine
    s = s & "'   used to ""hydrate"" the class" & vbNewLine
    s = s & "Public Sub Deserialize(SerializedString As String)" & vbNewLine
    s = s & "    Dim s As String" & vbNewLine
    s = s & "    s = SerializedString" & vbNewLine
    s = s & "    " & vbNewLine
    For i = LBound(VarTypePairs) To UBound(VarTypePairs) Step 2
        s = s & "    Dim v" & VarTypePairs(i) & " As Variant: v" & VarTypePairs(i) & " = Parse(s, """ & VarTypePairs(i) & """)" & vbNewLine
    Next i
    s = s & "    " & vbNewLine
    
    For i = LBound(VarTypePairs) To UBound(VarTypePairs) Step 2
        s = s & "    If Not IsNull(v" & VarTypePairs(i) & ") Then" & vbNewLine
        s = s & "        this." & VarTypePairs(i) & " = v" & VarTypePairs(i) & "" & vbNewLine
        s = s & "        this.Has" & VarTypePairs(i) & " = True" & vbNewLine
        s = s & "    End If" & vbNewLine
    Next i
    s = s & "End Sub" & vbNewLine
    s = s & vbNewLine
    s = s & ""

    
    WriteModule "dto" & DtoName, s, "Class"
End Sub

'Produces a code module named {ModName} with the Contents passed
'   - If the module exists, it is overwritten
'   - If the module does not exist, it is created and populated
'   - No code is included, not even "Option Explicit/Compare Database" lines
'Source: https://nolongerset.com/writing-code-with-code-in-vba/
Private Sub WriteModule(ModName As String, Contents As String, ModuleType As String)
    On Error GoTo Err_WriteModule

    Dim VBProj As Object ' VBIDE.VBProject
    Dim VBComp As Object ' VBIDE.VBComponent
        
    'Get the code module object
    Set VBProj = VBE.ActiveVBProject
    Set VBComp = VBProj.VBComponents(ModName)
    
    'Delete the contents of the module
    VBComp.CodeModule.DeleteLines 1, VBComp.CodeModule.CountOfLines
    
    'Update the contents of the module
    VBComp.CodeModule.AddFromString Contents


Exit_WriteModule:
    Exit Sub
Err_WriteModule:
    Select Case Err.Number
    Case 9  'Subscript out of range
        Select Case ModuleType
        Case "Standard"
            Set VBComp = VBProj.VBComponents.Add(1)  'vbext_ct_StdModule
        Case "Class"
            Set VBComp = VBProj.VBComponents.Add(2)  'vbext_ct_ClassModule
        Case Else
            'Throw "Unsupported ModuleType: {0}", ModuleType
        End Select
        VBComp.Name = ModName
        Resume
    Case Else
        'LogErr is a standard error handling routine I wrote;
        '  you may want to replace the MsgBox line below with 
        '  some sort of error logging/handling routine of your own
        'LogErr Err, Errors, "DesignProcedures", "WriteModule"
        MsgBox Err.Description
    End Select
    Resume Exit_WriteModule
End Sub

StringFunctions standard code module

'--== StringFunctions standard code module ==--
Option Compare Database
Option Explicit

'---------------------------------------------------------------------------------------
' Procedure : Conc
' Author    : Mike
' Source    : https://nolongerset.com/come-together/
' Date      : 1/23/2009 - 4/1/2015
' Purpose   : Concatenates two strings
' Notes     : Eliminates the need to strip off the leading/trailing delimiter when
'               building a string list
' 4/17/09   - If StartText is filled, but nextval is empty, then StartText is returned unchanged.
' 5/ 1/09   - Changed return type of conc from Variant to String.
' 4/ 1/15   - Allow passing Nulls as StartText.
'>>> Conc("1, 2, 3", "4")
' 1, 2, 3, 4
'>>> Conc("This", "that", " and ")
' This and that
'>>> Conc("Five", Null, " and ")
' Five
'>>> Conc(Null, "Dime", " and ")
' Dime
'>>> "#" & Conc(Null, Null) & "#"
' ##
'---------------------------------------------------------------------------------------
'
Function Conc(StartText As Variant, NextVal As Variant, Optional Delimiter As String = ", ") As String 'vv
    If Len(Nz(StartText)) = 0 Then
        Conc = Nz(NextVal)
    ElseIf Len(Nz(NextVal)) = 0 Then
        Conc = StartText
    Else
        Conc = StartText & Delimiter & NextVal
    End If
End Function

'---------------------------------------------------------------------------------------
' Procedure : Parse
' DateTime  : 7/16/2009 - 4/30/2015 17:41
' Author    : Mike
' Source    : https://nolongerset.com/part-and-parse-l/
' Purpose   : Parse a string of keys and values (such as a connection string) and return
'               the value of a specific key.
' Usage     - Use to pass multiple arguments to forms via OpenArgs
'           - Keep multiple arguments in the Tag property of forms and controls.
'           - Use to parse a user-entered search string.
' Notes     - Defaults to using connection string formatted key-value pairs.
'           - Specifying a ReturnType guarantees the type of the result and allows the
'               function to be safely called in certain situations.
'  7/23/09  : Modified to allow the use of a literal space as a delimiter while allowing
'               values to have spaces as well. For example:
'>>> Parse("Name : Mike Wolfe Address : 92 River Rd Zip : 18456","Address",12,":"," ")
' 92 River Rd
'  7/23/09  : Passing an empty key returns the start of the string until the first
'               key is found.  For example:
'>>> Parse("Mike Wolfe Address : 92 River Rd Zip : 18456","",12,":"," ")
' Mike Wolfe
'>>> Parse("BlueReqd=True; RedReqd=True; Reqd=False; GreenReqd=True", "Reqd", 11)
' False
'  4/30/15  : Allow for assignment characters to be used within a value; for example:
'>>> Parse("Caption=Test;IsIn=SELECT ID FROM MyTable WHERE FKey=1;Foo=Bar", "IsIn")
' SELECT ID FROM MyTable WHERE FKey=1
'---------------------------------------------------------------------------------------
'
Function Parse(Txt As Variant, Key As String, _
               Optional ReturnType As VbVarType = vbVariant, _
               Optional AssignChar As String = "=", _
               Optional Delimiter As String = ";") As Variant
    Dim EndPos As Integer, Result As Variant
    Result = Null
    If IsNull(Txt) Then
        Parse = Null
    ElseIf Len(Key) = 0 Then
        EndPos = InStr(Txt, AssignChar)
        If EndPos = 0 Then
            Result = Trim(Txt)
        Else
            If InStrRev(Txt, " ", EndPos) = EndPos - 1 Then
                EndPos = InStrRev(Txt, Delimiter, EndPos - 2)
            Else
                EndPos = InStrRev(Txt, Delimiter, EndPos)
            End If
            Result = Trim(Left(Txt, EndPos))
        End If
    Else
        Dim KeyStartPos As Integer, ValStartPos As Integer
        KeyStartPos = InStr(Txt, Key & AssignChar)
        'Allow for space between Key and Assignment Character
        If KeyStartPos = 0 Then
            KeyStartPos = InStr(Txt, Key & " " & AssignChar)
            If KeyStartPos > 0 Then ValStartPos = KeyStartPos + Len(Key & " " & AssignChar)
        Else
            ValStartPos = KeyStartPos + Len(Key & AssignChar)
        End If
        If ValStartPos = 0 Then
            Parse = Null
        Else
            'Check prior characters to ensure we are not looking at a substring of another key
            Dim i As Long
            For i = KeyStartPos - 1 To 1 Step -1
                Dim ThisChar As String
                ThisChar = Mid(Txt, i, 1)
                Select Case ThisChar
                Case Delimiter
                    'we're at the delimiter, no need for further checking
                    Exit For
                    'note that the order of Case statements is important; we need to check
                    '   for the delimiter first in case space or tab are being used as delimiters
                Case " ", vbTab
                    'ignore whitespace
                Case Else
                    'it appears this is a substring of another key, so we'll make a recursive
                    '   call to this function starting with the character beyond the StartPos:
                    Parse = Parse(Mid(Txt, KeyStartPos + 1), Key, ReturnType, AssignChar, Delimiter)
                    Exit Function
                End Select
            Next i
            
            'Allow for assignment characters to be used within a value
            Dim NextDelimPos As Long
            NextDelimPos = InStr(ValStartPos, Txt, Delimiter)
            Dim BeginEndPosSearch As Long
            BeginEndPosSearch = ValStartPos
            Do
                EndPos = InStr(BeginEndPosSearch, Txt, AssignChar)
                BeginEndPosSearch = EndPos + 1
            Loop Until EndPos > NextDelimPos Or EndPos = 0
            '----------------------------------------------------------
            
            If EndPos = 0 Then
                If Right(Txt, Len(Delimiter)) = Delimiter Then
                    Result = Trim(Mid(Txt, ValStartPos, _
                                      Len(Txt) - Len(Delimiter) - ValStartPos + 1))
                Else
                    Result = Trim(Mid(Txt, ValStartPos))
                End If
            Else
                If InStrRev(Txt, Delimiter, EndPos) = EndPos - 1 Then
                    EndPos = InStrRev(Txt, Delimiter, EndPos - 2)
                Else
                    EndPos = InStrRev(Txt, Delimiter, EndPos)
                End If
                If EndPos < ValStartPos Then
                    Result = Trim(Mid(Txt, ValStartPos))
                Else
                    Result = Trim(Mid(Txt, ValStartPos, EndPos - ValStartPos))
                End If
            End If

        End If
    End If
    Select Case ReturnType
    Case vbBoolean
        If IsNull(Result) Or Len(Result) = 0 Or Result = "False" Then
            Parse = False
        Else
            Parse = True
            If IsNumeric(Result) Then
                If Val(Result) = 0 Then Parse = False
            End If
        End If

    Case vbCurrency, vbDecimal, vbDouble, vbInteger, vbLong, vbSingle
        If IsNumeric(Result) Then
            Select Case ReturnType
            Case vbCurrency: Parse = CCur(Result)
            Case vbDecimal: Parse = CDec(Result)
            Case vbDouble: Parse = CDbl(Result)
            Case vbInteger: Parse = CInt(Result)
            Case vbLong: Parse = CLng(Result)
            Case vbSingle: Parse = CSng(Result)
            End Select
        Else
            Select Case ReturnType
            Case vbCurrency: Parse = CCur(0)
            Case vbDecimal: Parse = CDec(0)
            Case vbDouble: Parse = CDbl(0)
            Case vbInteger: Parse = CInt(0)
            Case vbLong: Parse = CLng(0)
            Case vbSingle: Parse = CSng(0)
            End Select
        End If

    Case vbDate
        If IsDate(Result) Then
            Parse = CDate(Result)
        ElseIf IsNull(Result) Then
            Parse = 0
        ElseIf IsDate(Replace(Result, "#", "")) Then
            Parse = CDate(Replace(Result, "#", ""))
        Else
            Parse = 0
        End If

    Case vbString
        Parse = Nz(Result, vbNullString)

    Case Else
        If IsNull(Txt) Then
            Parse = Null
        ElseIf Result = "True" Then
            Parse = True
        ElseIf Result = "False" Then
            Parse = False
        ElseIf IsNumeric(Result) Then
            Parse = Val(Result)
        Else
            Parse = Result
        End If
    End Select
End Function

ErrorMod standard code module

'--== ErrorMod standard code module ==--
'see: https://nolongerset.com/throwing-errors-in-vba/
Option Compare Database
Option Explicit


'---------------------------------------------------------------------------------------
' Procedure : Throw
' Author    : Mike
' Date      : 7/24/2014 - 12/7/2016
' Purpose   : Throws a new error, calculating a unique error number by hashing the Msg.
' Notes     - Msg may contain one or more placeholders which will be substituted
'               with contents of the Notes() array.
'           - Contents of the Notes array will be enclosed in single quotes when they are
'               added to show that they are custom for a particular instance.
'           - The placeholders may contain quotes around them but it is not necessary.
'           - Tabs and newlines can be passed using escape sequences, \t and \n
' Usage     : Throw "Could not find file {0} for account:\n\n{1}", FName, AcctNum
'   Results : Could not find file 'C:\Temp\MyFile.txt' for account:
'
'             '123456'
'---------------------------------------------------------------------------------------
'
Public Sub Throw(Msg As String, ParamArray Notes() As Variant)
    Dim s As String, i As Integer
    s = Msg
    s = Replace(s, "\t", vbTab)
    s = Replace(s, "\n", vbNewLine)
    For i = LBound(Notes()) To UBound(Notes())
        Dim ReplTxt As String
        ReplTxt = "'" & Notes(i) & "'"
        s = Replace(s, "'{" & i & "}'", ReplTxt)
        s = Replace(s, "{" & i & "}", ReplTxt)
    Next i
    Err.Raise ErrNumFromMsg(Msg), , s
End Sub

'---------------------------------------------------------------------------------------
' Procedure : ErrNumFromMsg
' Author    : Mike
' Date      : 9/22/2015
' Purpose   : Converts a msg into a somewhat-unique hash.  This is a public convenience
'               function primarily made available for testing.
'---------------------------------------------------------------------------------------
'
Public Function ErrNumFromMsg(Msg As String) As Long
    ErrNumFromMsg = vbObjectError + GenerateErrNumFromMsgHash(Msg)
End Function

'---------------------------------------------------------------------------------------
' Procedure : GenerateErrNumFromMsgHash
' Author    : Mike
' Date      : 7/24/2014
' Purpose   : Given a string of text, reliably reproduces a number between 513–65535
'               to use when generating user-defined errors.
' Notes     - This is an overly simplistic hash method.  It is likely rife with potential
'               collisions.  However, we are not too concerned with the occasional
'               collision, so it seems like a good trade-off.
' Usage     :
'>> GenerateErrNumFromMsgHash("Could not find file {0} for account {1}")
' 41945
'---------------------------------------------------------------------------------------
'
Private Function GenerateErrNumFromMsgHash(Msg As String) As Long
    Const ValRange As Long = 65535 - 513
    Const ShiftVal As Long = 513
    Dim i As Long, Val As Long
    For i = 1 To Len(Msg)
        Val = (Val + (Asc(Mid(Msg, i, 1)) ^ 2)) Mod ValRange
    Next i
    GenerateErrNumFromMsgHash = Val + ShiftVal
 End Function

Original photo by Giftpundits.com from Pexels (modified by Mike Wolfe)