"Complex" DTOs in VBA
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 DateComplex 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 SubI 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.FormatForDuplexBenefits 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:
- I generate the DTO with a single line of code (see below)
- 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"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:
- Copy the
CreateDTOline from the comments at the top of the DTO class - Paste the
CreateDTOline into the immediate window - 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 SubStringFunctions 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 FunctionErrorMod 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 FunctionOriginal photo by Giftpundits.com from Pexels (modified by Mike Wolfe)