3
\$\begingroup\$

Purpose

I managed to get completely nerd-sniped earlier today by a question over on SO and decided to take a stab at adapting my numeric input wrapper for TextBoxes into one that would handle numeric date input in various different formats and automatically add the delimiters.

I usually do VBA user input handling into wrapper classes that handle the appropriate events for 2 main reasons: First, it takes a lot of superfluous clutter out of the form's code-behind - if I'm using several different input wrappers, it can get messy fast (evidenced by the size of this one). Second, it makes it a lot easier to import them into a project that will use them.

Note that the second goal is driving the architecture somewhat - if this was implemented as a stand-alone ActiveX control that was referenced by the project, I would have split it up into several different classes to address specific areas of concern.

Other Design Considerations

There are a couple things that people commonly get wrong with using the UI events to limit data input into a TextBox. This implementation addresses the following:

  • Keyboard input is not the only way that input needs to be handled. The MSForms TextBox also supports copy and paste, drag and drop, data binding, etc.
  • The representation of the data in the Text property is not necessarily the value that you're looking for from the user. What is displayed should be treated as UX, not data.
  • Validation feedback should not be performed by the control - it should expose a way to check for validity, but how that is handled (i.e. displaying a message box, setting focus back, etc.) should be up to the parent of the control.

Implementation

The following code all goes in a class module named DateInputWrapper.cls - it is split into sections below for readability on SE. The full class is available on Pastebin (no, that really is their VB syntax highlighting...).

Declarations Section

Option Explicit

Public Enum DateOrder
    MDY
    DMY
    YMD
End Enum

Private Type DateInputWrapperMembers
    Delimiter As String
    TwoDigitYear As Boolean
    Order As DateOrder
    NumericDate As String
End Type

Private Const DELETE_KEY As Integer = 46
Private Const BACKSPACE_KEY As Integer = 8

Private this As DateInputWrapperMembers
Private WithEvents wrapped As MSForms.TextBox
Private formatting As Boolean

Public Members

Private Sub Class_Initialize()
    this.Delimiter = "-"
    this.Order = DateOrder.YMD
End Sub

Public Property Set Wrapping(ByVal rhs As MSForms.TextBox)
    Set wrapped = rhs
End Property

Public Property Get Wrapping() As MSForms.TextBox
    Set Wrapping = wrapped
End Property

Public Property Let Delimiter(ByVal rhs As String)
    If Len(rhs) > 1 Then
        Err.Raise 5 'invalid argument
   End If
    this.Delimiter = rhs
End Property

Public Property Get Delimiter() As String
    Delimiter = this.Delimiter
End Property

Public Property Let Order(ByVal rhs As DateOrder)
    this.Order = rhs
End Property

Public Property Get Order() As DateOrder
    Order = this.Order
End Property

Public Property Let TwoDigitYear(ByVal rhs As Boolean)
    this.TwoDigitYear = rhs
End Property

Public Property Get TwoDigitYear() As Boolean
    TwoDigitYear = this.TwoDigitYear
End Property

Public Property Let DateValue(ByVal Value As Variant)
    Dim valueType As VbVarType
    valueType = VarType(Value)
    Select Case True
        Case valueType = vbDate, IsNumeric(Value)
            LoadFromDate CDate(Value)
            SetTextFromInternal
        Case valueType = vbString
            wrapped.Text = CStr(Value)
        Case Else
            Err.Raise 5 'invalid argument
   End Select
End Property

'Output value, returns Empty if invalid.
Public Property Get DateValue() As Variant
    If Not IsValidDate Then Exit Property
    DateValue = DateSerial(CInt(YearValue), CInt(MonthValue), CInt(DayValue))
End Property

'Returns a string suitable for passing to Format$ that matches the TextBox setup.
Public Property Get DateFormat() As String
    Dim yearFormat As String
    yearFormat = String$(IIf(TwoDigitYear, 2, 4), "y")
    Select Case Order
        Case DateOrder.MDY
            DateFormat = "mm" & Delimiter & "dd" & Delimiter & yearFormat
        Case DateOrder.DMY
            DateFormat = "dd" & Delimiter & "mm" & Delimiter & yearFormat
        Case DateOrder.YMD
            DateFormat = yearFormat & Delimiter & "mm" & Delimiter & "dd"
    End Select
End Property

Public Property Get FormattedDate() As String
    ReDim elements(2) As String

    Select Case Order
        Case DateOrder.MDY
            elements(0) = MonthValue
            elements(1) = DayValue
            elements(2) = YearValue
        Case DateOrder.DMY
            elements(0) = DayValue
            elements(1) = MonthValue
            elements(2) = YearValue
        Case DateOrder.YMD
            elements(0) = YearValue
            elements(1) = MonthValue
            elements(2) = DayValue
    End Select

    If elements(0) = vbNullString Then Exit Property

    Dim idx As Long
    For idx = 1 To 2
        If elements(idx) = vbNullString Then
            ReDim Preserve elements(idx - 1)
            Exit For
        End If
    Next
    FormattedDate = Join(elements, this.Delimiter)
End Property

Public Property Get IsValidDate() As Boolean
    Select Case False
        Case Len(YearValue) <> IIf(this.TwoDigitYear, 2, 4)
        Case Len(DayValue) <> 2
        Case Len(MonthValue) <> 2
        Case Else
            Exit Property
    End Select

    Dim dayOfMonth As Long, valueOfYear As Long
    dayOfMonth = CLng(DayValue)
    valueOfYear = CLng(YearValue)

    If this.TwoDigitYear Then
        'Note: This will break in the year 2100.
       valueOfYear = valueOfYear + IIf(valueOfYear < CLng(Year(Date)) Mod 100, 2000, 1900)
    ElseIf valueOfYear < 100 Then
        Exit Property
    End If

    Select Case CLng(MonthValue)
        Case 2
            If IsLeapYear(valueOfYear) Then
                IsValidDate = dayOfMonth > 0 And dayOfMonth <= 29
            Else
                IsValidDate = dayOfMonth > 0 And dayOfMonth <= 28
            End If
        Case 4, 6, 9, 11
            IsValidDate = dayOfMonth > 0 And dayOfMonth <= 30
        Case 1, 3, 5, 7, 8, 10, 12
            IsValidDate = dayOfMonth > 0 And dayOfMonth <= 31
    End Select
End Property

Event Handlers

Private Sub wrapped_Change()
    'Prevent re-entry from SetTextFromInternal
   If formatting Then Exit Sub

    With Wrapping
        'Handle pasting and drag-drop, and any other random input methods.
       If .Text Like "*[!0-9" & Delimiter & "]*" Then
            SetTextFromInternal
            Exit Sub
        End If
        'Handle keyboard input.
       this.NumericDate = Left$(Replace$(.Text, Delimiter, vbNullString), IIf(this.TwoDigitYear, 6, 8))
        SetTextFromInternal
    End With
End Sub

'Accept only numbers, and limit digits.
Private Sub wrapped_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If Not Chr$(KeyAscii) Like "[0-9]" Or Len(this.NumericDate) = IIf(this.TwoDigitYear, 6, 8) Then
        KeyAscii.Value = 0
    End If
End Sub

'Delete and backspace are handled on key-down to keep the internal version in sync.
Private Sub wrapped_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    With wrapped
        Dim caret As Long, characters As Long
        caret = .SelStart
        characters = .SelLength

        If KeyCode <> BACKSPACE_KEY And KeyCode <> DELETE_KEY Then
            If .SelLength > 0 Then
                'Over-typing selection.
               HandleSelectionDelete .SelStart, characters
            End If
            Exit Sub
        End If

        Dim newCaret As Long
        If KeyCode = BACKSPACE_KEY And characters = 0 Then
            newCaret = HandleBackspace(caret, characters)
        ElseIf characters = 0 Then
            newCaret = HandleDelete(caret)
        Else
            newCaret = HandleSelectionDelete(.SelStart, characters)
        End If
    End With

    SetTextFromInternal newCaret
    KeyCode.Value = 0
End Sub

Private Members

Private Property Get YearValue() As String
    If Order = DateOrder.YMD Then
        YearValue = Left$(this.NumericDate, IIf(this.TwoDigitYear, 2, 4))
    Else
        Dim characters As Long
        characters = Len(this.NumericDate)
        If characters <= 4 Then Exit Property
        YearValue = Right$(this.NumericDate, characters - 4)
    End If
End Property

Private Property Get MonthValue() As String
    Select Case Order
        Case DateOrder.DMY
            MonthValue = Mid$(this.NumericDate, 3, 2)
        Case DateOrder.MDY
            MonthValue = Left$(this.NumericDate, 2)
        Case DateOrder.YMD
            MonthValue = Mid$(this.NumericDate, IIf(this.TwoDigitYear, 3, 5), 2)
    End Select
End Property

Private Property Get DayValue() As String
    Select Case Order
        Case DateOrder.MDY
            DayValue = Mid$(this.NumericDate, 3, 2)
        Case DateOrder.DMY
            DayValue = Left$(this.NumericDate, 2)
        Case DateOrder.YMD
            Dim characters As Long
            characters = Len(this.NumericDate) - 2 - IIf(this.TwoDigitYear, 2, 4)
            If characters <= 0 Then Exit Property
            DayValue = Right$(this.NumericDate, characters)
    End Select
End Property

Private Sub LoadFromDate(ByVal Value As Date)
    Dim formattedYear As String
    formattedYear = Right$(CStr(Year(Value)), IIf(this.TwoDigitYear, 2, 4))

    Select Case Order
        Case DateOrder.MDY
            this.NumericDate = Format$(Month(Value), "00") & Format$(Day(Value), "00") & formattedYear
        Case DateOrder.DMY
            this.NumericDate = Format$(Day(Value), "00") & Format$(Month(Value), "00") & formattedYear
        Case DateOrder.YMD
            this.NumericDate = formattedYear & Format$(Month(Value), "00") & Format$(Day(Value), "00")
    End Select
End Sub

Private Sub SetTextFromInternal(Optional ByVal caret As Variant)
    'Going to change the .Text, so set the re-entry flag.
   formatting = True
    With wrapped
        .Text = FormattedDate
        If Not IsMissing(caret) Then
            .SelStart = caret
        End If
    End With
    formatting = False
End Sub

Private Function HandleBackspace(ByVal caret As Long, ByVal characters As Long) As Long
    With wrapped
        If caret = 0 Then Exit Function
        If caret = characters Then
            this.NumericDate = Left$(this.NumericDate, Len(this.NumericDate) - 1)
        Else
            Dim adjustedCaret As Long
            adjustedCaret = caret - SpannedDelimiters(Left$(.Text, caret))
            this.NumericDate = Left$(this.NumericDate, adjustedCaret - 1) & _
                Right$(this.NumericDate, Len(this.NumericDate) - adjustedCaret)
        End If
        HandleBackspace = caret - 1
    End With
End Function

Private Function HandleDelete(ByVal caret As Long) As Long
    With wrapped
        Dim adjustedCaret As Long
        adjustedCaret = caret - SpannedDelimiters(Left$(.Text, caret))
        Dim characters As Long
        characters = Len(this.NumericDate)

        If adjustedCaret = characters Then
            HandleDelete = caret
            Exit Function
        End If

        If caret = 0 Then
            this.NumericDate = Right$(this.NumericDate, characters - 1)
        Else
            this.NumericDate = Left$(this.NumericDate, adjustedCaret) & _
                Right$(this.NumericDate, characters - adjustedCaret - 1)
            HandleDelete = caret + SpannedDelimiters(.SelText)
        End If
    End With
End Function

Private Function HandleSelectionDelete(ByVal caret As Long, ByVal selected As Long) As Long
    With wrapped
        Dim characters As Long
        characters = .TextLength

        If characters = selected Then
            this.NumericDate = vbNullString
        ElseIf caret = 0 Then
            this.NumericDate = Right$(.Text, characters - selected)
        ElseIf caret + selected = characters Then
            this.NumericDate = Left$(.Text, caret)
        Else
            this.NumericDate = Left$(.Text, caret) & Right$(.Text, characters - selected - caret)
        End If
        this.NumericDate = Replace$(this.NumericDate, Delimiter, vbNullString)
    End With
    HandleSelectionDelete = caret
End Function

Private Function SpannedDelimiters(ByVal testing As String) As Long
    If testing = vbNullString Then
        Exit Function
    End If
    SpannedDelimiters = UBound(Split(testing, Delimiter))
End Function

Private Function IsLeapYear(ByVal test As Long) As Boolean
    Select Case True
        Case test Mod 400
            IsLeapYear = True
        Case test Mod 100
        Case test Mod 4
            IsLeapYear = True
    End Select
End Function

Sample Usage

The following assumes a UserForm with a TextBox named TextBox1:

Option Explicit

Private dateInput As DateInputWrapper

Private Sub UserForm_Initialize()
    Set dateInput = New DateInputWrapper
    With dateInput
        Set .Wrapping = TextBox1
        .Delimiter = "."
        .DateValue = Date
        .Order = DateOrder.YMD
    End With
End Sub

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    If dateInput.IsValidDate Then
        Debug.Print dateInput.DateValue
    Else
        Debug.Print "Invalid date"
    End If
End Sub
\$\endgroup\$

1 Answer 1

Reset to default
1
\$\begingroup\$

Constants

 Private Const DELETE_KEY As Integer = 46
 Private Const BACKSPACE_KEY As Integer = 8

Obviously these constants refer to to KeyCodes, right? Well yeah but I still had to check. I would prefer to use the built in constants "vbKeyDelete" & "vbKeyBack" or "KeyCodeConstants.vbKeyDelete" & "KeyCodeConstants.vbKeyBack".

If you want to use your own names, I would have then refer to the built-in constants.

   Private Const DELETE_KEY As Integer = KeyCodeConstants.vbKeyDelete '46
   Private Const BACKSPACE_KEY As Integer = KeyCodeConstants.vbKeyBack '8

IsLeapYear: Function

This function does not work properly.

Private Function IsLeapYear(ByVal test As Long) As Boolean
    Select Case True
        Case test Mod 400
            IsLeapYear = True
        Case test Mod 100
        Case test Mod 4
            IsLeapYear = True
    End Select
End Function

The year is a leap year if you can divide it evenly by 4 with no remainder.

Private Function IsLeapYear(ByVal Value As Long) As Boolean
    IsLeapYear = Value Mod 4 = 0
End Function

Note: There are some conditions for leap year that I did not meet in my original code. However, my IsValidDate() replacement is correct. I simply let the VBA for me.

 Val(MonthValue) = Month(DateSerial(Val(YearValue), Val(MonthValue), Val(DayValue)))

IsValidDate: Property

The Select Case seems designed to exit the property if any condition evaluates as False. The intent is to prevent the property from returning True if the date parts are not the appropriate lengths. This does not work as intended.

Select Case False
    Case Len(YearValue) <> IIf(this.TwoDigitYear, 2, 4)
    Case Len(DayValue) <> 2
    Case Len(MonthValue) <> 2
    Case Else
        Exit Property
End Select

Let's substitute these values and break down the logic case by case:

this.TwoDigitYear = True
YearValue = "18"
DayValue = "01"
MonthValue = "01"

Case 1:

Case Len(YearValue) <> IIf(this.TwoDigitYear, 2, 4)
Case Len("18") <> IIf(True, 2, 4)
Case 2 <> 2
Case False

Since Case 1 evaluates to False the Select Case breaks here skipping the Case Else: Exit Property.

Case 2: 

Case Len(DayValue) <> 2
Case Len("01") <> 2
Case 2 <> 2

Case 3: 

Case Len(MonthValue) <> 2
Case Len("01") <> 2
Case 2 <> 2

Notice that cases 2 & 3 also evaluate to False; preventing the property from exiting due to improper input.

Both the IsLeapYear() and IsValidDate() can be replaced by ↓this code↓:

Public Function IsValidDate() As Boolean
    IsValidDate = Len(YearValue) = IIf(TwoDigitYear, 2, 4) And _
                  Len(DayValue) = 2 And _
                  Len(MonthValue) = 2 And _
                  Val(MonthValue) = Month(DateSerial(Val(YearValue), Val(MonthValue), Val(DayValue)))
End Function

Order: Property

Changing the date order or delimiter should cause a value update.

This code sample will return an invalid date because the date was set using the default date order is DateOrder.YMD.

With dateInput
    Set .Wrapping = TextBox1
    .Delimiter = "."
    .DateValue = Date
    .Order = DateOrder.MDY
End With

User Experience (UX)

Being able to add dates without using a delimiter is super helpful. If you are used to doing it. Most people are not used to it. You could greatly improve the UX by converting the date parts and delimiter to the correct format and allow delimiters KeyCodes.

As a user I would like to be able to type 2018.01.31, 2018.1.31, 2018/01/31 or 18-01-31 and have the code automatically correct the formats and delimiters.

Just to be consistent with most of my posts, I am going to make a totally ridiculous suggestion. Add a placeholder. Wouldn't it be great to have the empty textbox display it's date format?

\$\endgroup\$
5
  • \$\begingroup\$ The leap year calculation should be correct. Divisible by 4 was in the Julian calendar, but it was corrected in the Gregorian. Re the IsValidDate, :doh: I was victim of my own last minute refactor - those should have been comma delimited instead of 3 separate cases. Agreed that changes to the setup should trigger updates too (I realized that about an hour after I posted the code). You are absolutely correct about KeyCodeConstants - completely spaced that they were already defined. \$\endgroup\$
    – Comintern
    Commented Oct 22, 2018 at 5:17
  • \$\begingroup\$ Re the UX, persistable input masks would be an easy change (or perhaps another configuration), but were not in the problem domain. Thanks for the review! \$\endgroup\$
    – Comintern
    Commented Oct 22, 2018 at 5:18
  • \$\begingroup\$ @Comintern Aww...thanks for the correction on the Gregorian calendar. I had test my code against Teachers Page - Leap Year that goes back to 1908. But you are correct my code does not take in all scenarios. My isValidDate() replacement is still correct because I let the VBA handle the leap years. \$\endgroup\$
    – TinMan
    Commented Oct 22, 2018 at 10:38
  • \$\begingroup\$ The logic for your isLeapYear() function is backwards. Compare it this answer to How do you find Leapyear in VBA?. Notice that all the conditions are that ? Mod ? = 0 where as your code is ? Mod ? > 0. \$\endgroup\$
    – TinMan
    Commented Oct 22, 2018 at 10:43
  • \$\begingroup\$ I realized after I shut my computer down that the placeholder should be its own class/ \$\endgroup\$
    – TinMan
    Commented Oct 22, 2018 at 10:44

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.