Insert Date in TextBox - VBA - excel

Question

I know that we can use function Date in forms for the insertion of the date. But for some dates (such as Hijri Shamsi and Hijri lunar history, etc.), this is impossible and difficult. So I wrote a code that works with the text box. But I think the code that I wrote can be simpler. Do you have a solution to make it simpler?
For example: checking the slash or preventing of Double message display for the moon and day error.
Thanks in advance for the friends who respond.
Private Sub TextBox1_Change()
'To check the slash in the correct place
If Mid(TextBox1, 1) = "/" Or Mid(TextBox1, 2) = "/" Or Mid(TextBox1, 3) = "/" Or Mid(TextBox1, 4) = "/" Or Mid(TextBox1, 6) = "/" Or Mid(TextBox1, 7) = "/" Or Mid(TextBox1, 9) = "/" Or Mid(TextBox1, 10) = "/" Then
MsgBox "Please insert date with format: YYYYMMDD or YYYY/MM/DD"
SendKeys ("{BACKSPACE}")
End If
'Insert the slash automatically
If TextBox1.TextLength = 8 Then
Me.TextBox1.Value = Format(Me.TextBox1.Value, "0000/00/00")
End If
'Year Error!
If Mid(TextBox1, 4) = 0 Then
MsgBox "Year Error!" & vbNewLine & "Please insert date with format: YYYYMMDD or YYYY/MM/DD"
With TextBox1
.SelStart = 0
.SelLength = Len(.Text)
End With
Exit Sub
End If
'Month Error!
If TextBox1.TextLength = 10 Then
If Mid(TextBox1.Value, 6, 2) = 0 Or Mid(TextBox1.Value, 6, 2) > 12 Then
MsgBox "Month Error!" & vbNewLine & "Please insert date with format: YYYYMMDD or YYYY/MM/DD"
With TextBox1
.SelStart = 5
.SelLength = 2
'.SelText = ""
End With
Exit Sub
End If
End If
'Day Error!
If TextBox1.TextLength = 10 Then
If Mid(TextBox1.Value, 9, 2) = 0 Or Mid(TextBox1.Value, 9, 2) > 31 Then
MsgBox "Day Error!" & vbNewLine & "Please insert date with format: YYYYMMDD or YYYY/MM/DD"
With TextBox1
.SelStart = 8
.SelLength = 2
End With
Exit Sub
End If
End If
End Sub
Private Sub textbox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'Accept only number and slash
If Not Chr(KeyAscii) Like "[0-9,/ ]" Then
KeyAscii = 0
MsgBox "Only Numbers Allowed!" & vbNewLine & "Please insert date with format: YYYYMMDD or YYYY/MM/DD"
With TextBox1
.SetFocus
Exit Sub
End With
End If
End Sub

Answer 1

I am not familiar enough with the calendar forms you're dealing with, so please understand my example based on a western-style calendar.
The way you're performing some of your error checking somewhat obscures the values you'e checking. For example,
If Mid(TextBox1.Value, 6, 2) = 0 Or Mid(TextBox1.Value, 6, 2) > 12 Then
is a perfectly valid check, but you're overusing the Mid function. One suggestion is to parse the date string and pull out substrings into values you're looking for. As in:
Dim month As Long
month = CLng(Mid$(TextBox1.Value, 6, 2))
If (month = 0) Or (month > 12) Then
this makes more intuitive sense. Yes, it creates an extra variable, but it makes your code much more readable.
Here's my (untested) version of your code as another example of how it can be done. Notice that I'm separating the error checking into a separate function because it's more involved. (This way it isn't cluttering the main routine.)
EDIT: Answer has been updated and tested. Changed the event code from TextBox1_Change and now catching two different events: LostFocus and KeyDown in order to kick off a validation when the user clicks away from the textbox or types Enter while in the textbox.
Option Explicit
Private Enum ValidationError
LengthError
FormatError
YearError
MonthError
DayError
NoErrors
End Enum
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)
If KeyCode = Asc(vbCr) Then
ValidateDate
End If
End Sub
Private Sub TextBox1_LostFocus()
ValidateDate
End Sub
Private Sub ValidateDate()
With TextBox1
Select Case InputIsValidated(.text)
Case LengthError
MsgBox "Please insert date with format: YYYYMMDD or YYYY/MM/DD with only numbers and a '/'"
Case FormatError
MsgBox "Please insert date with format: YYYYMMDD or YYYY/MM/DD with only numbers and a '/'"
Case YearError
.SelStart = 0
.SelLength = 4
MsgBox "Invalid Year. Must be between 2015 and 2020"
Case MonthError
.SelStart = 5
.SelLength = 2
MsgBox "Invalid Month. Must be between 1 and 12"
Case DayError
.SelStart = 7
.SelLength = 2
MsgBox "Invalid Day. Must be between 1 and 31"
Case NoErrors
'--- nothing to do, it's good!
MsgBox "It's good!"
End Select
End With
End Sub
Private Function InputIsValidated(ByRef text As String) As ValidationError
'--- perform all sorts of checks to validate the input
' before any processing
'--- MUST be the correct length
If (Len(text) <> 8) And (Len(text) <> 10) Then
InputIsValidated = LengthError
Exit Function
End If
'--- check if all characters are numbers
Dim onlyNumbers As String
onlyNumbers = Replace(text, "/", "")
If Not IsNumeric(onlyNumbers) Then
InputIsValidated = FormatError
Exit Function
End If
Dim yyyy As Long
Dim mm As Long
Dim dd As Long
yyyy = Left$(onlyNumbers, 4)
mm = Mid$(onlyNumbers, 5, 2)
dd = Right$(onlyNumbers, 2)
'--- only checks if the numbers are in range
' you can make this more involved if you want to check
' if, for example, the day for February is between 1-28
If (yyyy < 2015) Or (yyyy > 2020) Then
InputIsValidated = YearError
Exit Function
End If
If (mm < 1) Or (mm > 12) Then
InputIsValidated = MonthError
Exit Function
End If
If (dd < 1) Or (dd > 31) Then
InputIsValidated = DayError
Exit Function
End If
text = onlyNumbers
InputIsValidated = NoErrors
End Function

Answer 2

Thanks to #PeterT, I corrected the code with guidance #PeterT and I give it to all the interested people. Enjoy it.
Option Explicit
Private Enum ValidationError
LengthError
FormatError
YearError
MonthError
DayError
NoErrors
End Enum
Private Sub TextBox1_Change()
'To check the slash in the correct place
If TextBox1.TextLength = 10 Then
If InStr(Left(TextBox1, 4), "/") Or InStr(Mid(TextBox1, 6, 2), "/") Or InStr(Mid(TextBox1, 9, 2), "/") <> 0 Then
MsgBox "Please insert date with format: YYYYMMDD or YYYY/MM/DD"
With TextBox1
.SelStart = 0
.SelLength = Len(.text)
End With
End If
End If
'Insert the slash automatically
If TextBox1.TextLength = 8 Then
If InStr(TextBox1, "/") Then
'nothing
Else
Me.TextBox1.Value = Format(Me.TextBox1.Value, "0000/00/00")
End If
End If
End Sub
Private Sub textbox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'Accept only number and slash
If Not Chr(KeyAscii) Like "[0-9,/ ]" Then
KeyAscii = 0
MsgBox "Only Numbers Allowed!" & vbNewLine & "Please insert date with format: YYYYMMDD or YYYY/MM/DD"
End If
End Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = Asc(vbCr) Then
ValidateDate
End If
End Sub
Private Sub TextBox1_LostFocus()
ValidateDate
End Sub
Private Sub ValidateDate()
With TextBox1
Select Case InputIsValidated(.text)
Case LengthError
MsgBox "Please insert date with format: YYYYMMDD or YYYY/MM/DD with only numbers and a '/'"
Case FormatError
MsgBox "Please insert date with format: YYYYMMDD or YYYY/MM/DD with only numbers and a '/'"
Case YearError
.SelStart = 0
.SelLength = 4
MsgBox "Invalid Year. Must be between 2015 and 2020"
Case MonthError
.SelStart = 5
.SelLength = 2
MsgBox "Invalid Month. Must be between 1 and 12"
Case DayError
.SelStart = 8
.SelLength = 2
MsgBox "Invalid Day. Must be between 1 and 31"
Case NoErrors
'--- nothing to do, it's good!
MsgBox "It's good!"
End Select
End With
End Sub
Private Function InputIsValidated(ByRef text As String) As ValidationError
'--- perform all sorts of checks to validate the input
' before any processing
'--- MUST be the correct length
If InStr(TextBox1, "/") And TextBox1.TextLength < 10 Then
InputIsValidated = FormatError
Exit Function
End If
Dim yyyy As Long
Dim mm As Long
Dim dd As Long
yyyy = Left$(TextBox1, 4)
mm = Mid$(TextBox1, 6, 2)
dd = Right$(TextBox1, 2)
'--- only checks if the numbers are in range
' you can make this more involved if you want to check
' if, for example, the day for February is between 1-28
If (yyyy < 2015) Or (yyyy > 2020) Then
InputIsValidated = YearError
Exit Function
End If
If (mm < 1) Or (mm > 12) Then
InputIsValidated = MonthError
Exit Function
End If
If (dd < 1) Or (dd > 31) Then
InputIsValidated = DayError
Exit Function
End If
text = TextBox1
InputIsValidated = NoErrors
End Function