VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "DateInputWrapper"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
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
Attribute wrapped.VB_VarHelpID = -1
Private formatting As Boolean

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

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 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 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