Date input wrapper for TextBox

Question

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

Answer 1

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?

• Comintern: 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.
• Comintern: 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!
• TinMan: @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.
• TinMan: 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.
• TinMan: I realized after I shut my computer down that the placeholder should be its own class/