Excel Form TextBox Date Input Mask - VBA

[Jameo]

Hi all,

Yesterday I found the need to create an Input Mask to verify a date. After a lot of searching I didn't find one that really met my needs, so I had to write one.

Here it is:

Private Sub txtDate_Change()
GoTo ValCheck:
ErMsg:
MsgBox ("Incorrect date")
txtDate.Value = vbNullString
Exit Sub
ValCheck:
With txtDate
Select Case Len(.Value)
    Case 1
        If .Value > 3 Then
        GoTo ErMsg
        End If
    
    Case 2
        Select Case Left(.Value, 1)
            Case Is = 3
                If Mid(.Value, 2, 1) > 1 Then
                    GoTo ErMsg
                End If
            Case Else
                If Mid(.Value, 2, 1) > 9 Then
                    GoTo ErMsg
                End If
            End Select
    Case 3
        If Not Mid(.Value, 3, 1) = "/" Then
            GoTo ErMsg
        End If
    Case 4
        Select Case Mid(.Value, 4, 1)
            Case Is > 1
                GoTo ErMsg
        Case Else
        
        End Select
    Case 5
        Select Case Mid(.Value, 5, 1)
            Case 9
                If Mid(.Value, 1, 2) > 30 Then
                    GoTo ErMsg
                End If
            Case 4
                If Mid(.Value, 1, 2) > 30 Then
                    GoTo ErMsg
                End If
            Case 6
                If Mid(.Value, 1, 2) > 30 Then
                    GoTo ErMsg
                End If
            End Select
                If Mid(.Value, 1, 2) > 30 And Mid(.Value, 4, 2) = 11 Then
                    GoTo ErMsg
                End If
                If Mid(.Value, 4, 1) = 1 And Mid(.Value, 5, 1) > 2 Then
                    GoTo ErMsg
                End If
        Case 6
            If Not Mid(.Value, 6, 1) = "/" Then
                GoTo ErMsg
            End If
        Case 10
            If Mid(.Value, 7, 4) < 1990 Or Mid(.Value, 7, 4) > CInt(Year(Now())) Then
                GoTo ErMsg
            End If
        Case Is > 10
            GoTo ErMsg

    
End Select
If Len(.Value) = 10 Then
    If CDate(.Value) > Date Then
    
        MsgBox ("Date is in Future")
    
    End If
End If
End With

End Sub

I think it works pretty well and traps out the majority of the common errors. Hopefully it will help someone out.

I should note, this is for UK date Format, and has some error trapping to rule out future dates.

Also, I went along the route of checking each individual digit, rather than using a timer. Seemed to be a better solution.

There may be some erros, if you find any when using this it would be useful if you post them back here for everyone to see.

 

[tlowry]

' So here's my approach - Let the computer do the work
‘
‘ The CDate function takes in a string and converts it to a date, if it can. An error is generated if it can’t. CDate checks for everything you can think of and more

’ leap year (including turn of the century exceptions)
‘ mm/dd/yy vs. dd/mm/yy
‘ leading spaces
‘ two or four digit years
‘ oct-19-1946
‘ October 3, 44


[FONT=&quot]Private Sub CommandButton1_Click()
On Local Error GoTo Baddates
With Me.txtDate
Dim dTest As Date
dtesl = CDate(.Text)
End With
Exit Sub
Baddates:
MsgBox "Fix me"
End Sub

[/FONT]

 

[Norie]

Jameo

Seems a lot of work/code when you can just check if what's entered is a valid date using IsDate and if needed change it's format using Format.

 

[awatoto]

slightly rewritten the code:
=======================
Private Sub txtDate_Change()
On Local Error Resume Next
With txtDate
er_msg = "Incorrect Date"
GoTo ValCheck:
ErMsg:
.Value = Left(.Value, Len(.Value) - 1)
.SetFocus
Exit Sub
ValCheck:
Select Case Len(.Value)
Case 1
If .Value > 3 Then GoTo ErMsg
Case 2
Select Case Left(.Value, 1)
Case Is = 3
If Mid(.Value, 2, 1) > 1 Then GoTo ErMsg
Case Else
If Mid(.Value, 2, 1) > 9 Then GoTo ErMsg
End Select
Case 3, 6
k = Mid(.Value, Len(.Value), 1)
If Not ((k = "/") Xor (k = ".")) Then GoTo ErMsg
Case 4
Select Case Mid(.Value, 4, 1)
Case Is > 1
GoTo ErMsg
Case Else

End Select
Case 5
Select Case Mid(.Value, 5, 1)
Case 9
If Mid(.Value, 1, 2) > 30 Then GoTo ErMsg
Case 4
If Mid(.Value, 1, 2) > 30 Then GoTo ErMsg
Case 6
If Mid(.Value, 1, 2) > 30 Then GoTo ErMsg
End Select
If Mid(.Value, 1, 2) > 30 And Mid(.Value, 4, 2) = 11 Then GoTo ErMsg
If Mid(.Value, 4, 1) = 1 And Mid(.Value, 5, 1) > 2 Then GoTo ErMsg
Case 10
s = Mid(.Value, 7, 4)
k = Left(.Value, 6)
If CInt(s) < 1930 Then
.Value = k & "1930"
End If
If CInt(s) > Year(Now()) Then
.Value = k + CStr(Year(Now()))
End If

k = CDate(.Value)
If Err.Number <> 0 Then
Err.clear
s = Right(.Value, 8)
For i = 31 To 28 Step -1
k = CDate(CStr(i) & s)
If Err.Number = 0 Then Exit For
Err.clear
Next i
If k > CDate(Now()) Then
.Value = Format(Now(), "dd.mm.yyyy")
Else
.Value = Format(k, "dd.mm.yyyy")
End If
End If

Case Is > 10
.Value = Left(.Value, 10)

End Select
End With


End Sub


Private Sub txtDate_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If ((KeyAscii < 46 Or KeyAscii > 57)) Or (Len(txtDate.Value) = 10) Then KeyAscii = 0
If (KeyAscii = 47) Or (KeyAscii = 44) Then KeyAscii = 46
End Sub


=======================

 

[martinely95]

As I didn't find and input mask on the Internet, I created this code:

Dim NewString, MyString, maska As String
Dim mqsto As Variant

Private Sub TextBox1_Change()
If IsNumeric(Right(TextBox1.Text, 2)) And Len(TextBox1.Text) >= 11 Then
TextBox1.Text = Left(TextBox1.Text, Len(TextBox1.Text) - 1)
Else
mqsto = TextBox1.SelStart
MyString = TextBox1.Text
pos = InStr(1, MyString, "_")
If pos > 0 Then
NewString = Left(MyString, pos - 1)
Else
NewString = MyString
End If
If Len(NewString) < 11 Then
    TextBox1.Text = NewString & Right(maska, Len(maska) - Len(NewString))
    TextBox1.SelStart = Len(NewString)
End If
End If
If Len(TextBox1.Text) >= 11 Then
    TextBox1.Text = Left(TextBox1.Text, 10)
End If
End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
mqsto = TextBox1.SelStart
If KeyCode = 8 Then
    TextBox1.Text = maska
End If
End Sub

Private Sub UserForm_Initialize()
TextBox1.SelStart = 0
maska = "__.__.____"
End Sub

You have to put this on a Userform. Change the "TextBox1.Text" with the name of your textbox.

 

[martinely95]

As I didn't find and input mask on the Internet, I created this code:

Dim NewString, MyString, maska As String
Dim mqsto As Variant

Private Sub TextBox1_Change()
If IsNumeric(Right(TextBox1.Text, 2)) And Len(TextBox1.Text) >= 11 Then
TextBox1.Text = Left(TextBox1.Text, Len(TextBox1.Text) - 1)
Else
mqsto = TextBox1.SelStart
MyString = TextBox1.Text
pos = InStr(1, MyString, "_")
If pos > 0 Then
NewString = Left(MyString, pos - 1)
Else
NewString = MyString
End If
If Len(NewString) < 11 Then
    TextBox1.Text = NewString & Right(maska, Len(maska) - Len(NewString))
    TextBox1.SelStart = Len(NewString)
End If
End If
If Len(TextBox1.Text) >= 11 Then
    TextBox1.Text = Left(TextBox1.Text, 10)
End If
End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
mqsto = TextBox1.SelStart
If KeyCode = 8 Then
    TextBox1.Text = maska
End If
End Sub

Private Sub UserForm_Initialize()
TextBox1.SelStart = 0
maska = "__.__.____"
End Sub

You have to put this on a Userform. Change the "TextBox1.Text" with the name of your textbox.

Edit: add the line "TextBox1.Text = mask" In the UserForm_Initialize event after the line "maska = "__.__.____""

 

[tcfreer]

Hi All

I know this is a old thread however, the code that the OP has put here works great - however I need to allow for dates in the future, up to 2 years

Based on the code in the opening post can anyone point me on what to change?

I know its some were in this section code

Case 10
            If Mid(.Value, 7, 4) < 1990 Or Mid(.Value, 7, 4) > CInt(Year(Now())) Then

Is it as easy as removing the NOW clause?