Private Sub tbD_Change()
Dim d
d = tbD.Value
Select Case Len(d)
Case 1
If Not IsNumeric(d) Then d = ""
Case 2
If d Like "#/" Then
d = 0 & d
ElseIf Not IsNumeric(d) Then
d = ""
ElseIf CInt(d) > 31 Then
d = ""
Else
d = d & "/"
End If
Case 3
Case 4
If Not IsNumeric(Right(d, 1)) Then d = Left(d, 3)
Case 5
If d Like "##/#/" Then
Select Case CInt(Mid(d, 4, 1))
Case 1, 3, 5, 7, 8
d = Left(d, 3) & 0 & Right(d, 2)
Case 4, 6, 9
If CInt(Left(d, 2)) = 31 Then
d = Left(d, 3)
Else
d = Left(d, 3) & 0 & Right(d, 2)
End If
Case 2
If CInt(Left(d, 2)) > 29 Then
d = Left(d, 3)
Else
d = Left(d, 3) & 0 & Right(d, 2)
End If
End Select
ElseIf Not IsNumeric(Right(d, 2)) Then
d = Left(d, 3)
ElseIf CInt(Right(d, 2)) > 12 Then
d = Left(d, 3)
ElseIf CInt(Right(d, 2)) = 2 Then
If CInt(Left(d, 2)) > 29 Then
d = Left(d, 3)
Else
d = d & "/"
End If
Else
If CInt(Left(d, 2)) = 31 Then
Select Case CInt(Right(d, 2))
Case 2, 4, 6, 9, 11
d = Left(d, 3)
Case Else
d = d & "/"
End Select
Else
d = d & "/"
End If
End If
Case 6
Case 7
If Not IsNumeric(Right(d, 1)) Then d = Left(d, 6)
Case 8
If Not IsNumeric(Right(d, 2)) Then d = Left(d, 6)
Case 9
If Not IsNumeric(Right(d, 3)) Then d = Left(d, 6)
Case 10
If Not IsNumeric(Right(d, 4)) Then
d = Left(d, 6)
Else
If CInt(Mid(d, 4, 2)) = 2 And CInt(Left(d, 2)) = 29 Then
If CInt(Right(d, 2)) <> 0 Then
If CInt(Right(d, 2)) Mod 4 > 0 Then d = Left(d, 6)
Else
If CInt(Mid(d, 7, 2)) Mod 4 > 0 Then d = Left(d, 6)
End If
End If
End If
Case Else
d = ""
End Select
tbD.Value = d
End Sub
Private Sub tbD_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Dim d
d = tbD.Value
If Len(d) > 0 And Len(d) < 10 Then
Cancel = True
ElseIf Len(d) = 10 Then
On Error Resume Next
If IsError(CDate(d)) Then
d = ""
Cancel = True
tbD.Value = d
End If
On Error GoTo 0
End If
End Sub