Access JumpStart 2.0 | Blog

A Rapid Development Framework for Microsoft Access

CustomTags – Basic functionality coded!

by | Feb 26, 2025 | Blogging, MS Access, MS Access Forms, MS Access VBA Coding, TDD | 0 comments

This is a very basic set of 2 classes to produce a CustomTags object that can take an Access Control object from a form and store an internal dictionary intended to use string keys to store string values for that tag.

The ControlTags and ControlTag currently use early binding with the Scripting.Dictionary object which requires a reference in your project to the Microsoft Scripting Runtime library.

In addition, I used the RubberDuckVBA add-in to use the ‘@DefaultMember annotation to be able to make the syntax for accessing the tags very succinct. This requires you to install the RubberDuckVBA add in, run code inspections and run the fix tool for the two default member entries which will update the classes internally with the default member properties for the module.

Here is an example of the usage:

'Usage example

'Variable setups:
Dim testCT As CustomTags
Set testCT = New CustomTags
Dim ctl As Access.Control
Set ctl = Form_TestForm.TestControl
Dim strResult As String
    
'Usage:
testCT(ctl)("MyString") = "TestString"
strResult = testCT(ctl)("MyString")
Visual Basic

Since yesterday I renamed the first test I had written via RubberDuckVBA unit tests to more specifically describe what it does and added a second test. I am including the code of the entire test module for completeness, scroll to the last two Test Methods to see the actual tests:

'RubberDuckVBA test module Test_CustomTags
'@TestModule
'@Folder("Tests")

Option Compare Database

Option Explicit
Option Private Module

#Const LateBind = LateBindTests

#If LateBind Then
    Private Assert As Object
    Private Fakes As Object
#Else
    Private Assert As Rubberduck.AssertClass
    Private Fakes As Rubberduck.FakesProvider
#End If

'@ModuleInitialize
Private Sub ModuleInitialize()
    'this method runs once per module.
    #If LateBind Then
        Set Assert = CreateObject("Rubberduck.AssertClass")
        Set Fakes = CreateObject("Rubberduck.FakesProvider")
    #Else
        Set Assert = New Rubberduck.AssertClass
        Set Fakes = New Rubberduck.FakesProvider
    #End If
End Sub

'@ModuleCleanup
Private Sub ModuleCleanup()
    'this method runs once per module.
    Set Assert = Nothing
    Set Fakes = Nothing
End Sub

'@TestInitialize
Private Sub TestInitialize()
    'This method runs before every test in the module..
End Sub

'@TestCleanup
Private Sub TestCleanup()
    'this method runs after every test in the module.
End Sub

'@TestMethod("GivenCustomTagsObject")
Private Sub WhenPassedControlAndTagName_ThenReturnsEmptyStringForTagValue()
    On Error GoTo TestFail
    
    'Arrange:
    Dim testCT As CustomTags
    Set testCT = New CustomTags
    Dim ctl As Access.Control
    Set ctl = Form_TestForm.Controls("TestControl")
    Dim strResult As String
    
    'Act:
    strResult = testCT(ctl)("MyString")
    
    'Assert:
    Assert.AreEqual "", strResult

TestExit:
    '@Ignore UnhandledOnErrorResumeNext
    On Error Resume Next
    
    Exit Sub
TestFail:
    Assert.Fail "Test raised an error: #" & Err.Number & " - " & Err.Description
    Resume TestExit
End Sub

'@TestMethod("GivenCustomTagsObject")
Private Sub WhenPassedControlAndTagNameAndValue_ThenReturnsSameValueForTagName()
    On Error GoTo TestFail
    
    'Arrange:
    Dim testCT As CustomTags
    Set testCT = New CustomTags
    Dim ctl As Access.Control
    Set ctl = Form_TestForm.TestControl
    Dim strResult As String
    
    'Act:
    testCT(ctl)("MyString") = "TestString"
    strResult = testCT(ctl)("MyString")
    
    'Assert:
    Assert.AreEqual "TestString", strResult

TestExit:
    '@Ignore UnhandledOnErrorResumeNext
    On Error Resume Next
    
    Exit Sub
TestFail:
    Assert.Fail "Test raised an error: #" & Err.Number & " - " & Err.Description
    Resume TestExit
End Sub
Visual Basic

And now here are the two class modules:

'Class Module: CustomTags (plural)
Option Compare Database
Option Explicit

Private ctlDict As Scripting.Dictionary

'@DefaultMember
Public Function Controls(ctl As Access.Control) As CustomTag
    If IsEmpty(ctlDict(ctl)) Then Set ctlDict(ctl) = New CustomTag
    Set Controls = ctlDict(ctl)
End Function

Private Sub Class_Initialize()
    Set ctlDict = New Scripting.Dictionary
End Sub

Private Sub Class_Terminate()
    Set ctlDict = Nothing
End Sub
Visual Basic
'Class Module: CustomTag (singular)
Option Compare Database
Option Explicit

Private dictTagValues As Scripting.Dictionary

'@DefaultMember
Public Property Get Value() As Scripting.Dictionary
    Set Value = dictTagValues
End Property

Private Sub Class_Initialize()
    Set dictTagValues = New Scripting.Dictionary
End Sub

Private Sub Class_Terminate()
    Set dictTagValues = Nothing
End Sub
Visual Basic

Sign up For a Daily Email Adventure in Microsoft Access

Every business day (typically M-F), I'll send you an email with information about my ongoing journey as an advanced Access application developer. It will be loaded with my tips and musings.

    We won't send you spam. Unsubscribe at any time.
    Built with Kit

    Submit a Comment