在文本框中插入日期 - VBA
Insert Date in TextBox - VBA
我知道我们可以在表单中使用函数 Date 来插入日期。但对于某些年代（如回历沙姆西和回历太阴史等），这是不可能的，也是困难的。所以我写了一个与文本框一起工作的代码。但我认为我编写的代码可以更简单。您有使它更简单的解决方案吗？
例如：检查斜线或防止双信息显示月亮和星期错误。
先谢谢回复的朋友
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
我对您处理的日历形式不够熟悉，所以请理解我基于西式日历的示例。
您执行某些错误检查的方式在某种程度上掩盖了您正在检查的值。例如，
If Mid(TextBox1.Value, 6, 2) = 0 Or Mid(TextBox1.Value, 6, 2) > 12 Then
是一个完全有效的检查，但您过度使用了 Mid 函数。一个建议是解析日期字符串并将子字符串提取到您要查找的值中。如：
Dim month As Long
month = CLng(Mid$(TextBox1.Value, 6, 2))
If (month = 0) Or (month > 12) Then
这更直观。是的，它创建了一个额外的变量，但它使您的代码更具可读性。
这是我的（未经测试的）代码版本，作为如何完成它的另一个示例。请注意，我将错误检查分离到一个单独的函数中，因为它更复杂。 （这样就不会弄乱主程序。）
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
感谢@PeterT，我在@PeterT 的指导下更正了代码，并将其提供给所有感兴趣的人。 尽情享受.
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
我知道我们可以在表单中使用函数 Date 来插入日期。但对于某些年代（如回历沙姆西和回历太阴史等），这是不可能的，也是困难的。所以我写了一个与文本框一起工作的代码。但我认为我编写的代码可以更简单。您有使它更简单的解决方案吗？ 例如：检查斜线或防止双信息显示月亮和星期错误。
先谢谢回复的朋友
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
我对您处理的日历形式不够熟悉，所以请理解我基于西式日历的示例。
您执行某些错误检查的方式在某种程度上掩盖了您正在检查的值。例如，
If Mid(TextBox1.Value, 6, 2) = 0 Or Mid(TextBox1.Value, 6, 2) > 12 Then
是一个完全有效的检查，但您过度使用了 Mid 函数。一个建议是解析日期字符串并将子字符串提取到您要查找的值中。如：
Dim month As Long
month = CLng(Mid$(TextBox1.Value, 6, 2))
If (month = 0) Or (month > 12) Then
这更直观。是的，它创建了一个额外的变量，但它使您的代码更具可读性。
这是我的（未经测试的）代码版本，作为如何完成它的另一个示例。请注意，我将错误检查分离到一个单独的函数中，因为它更复杂。 （这样就不会弄乱主程序。）
EDIT: Answer has been updated and tested. Changed the event code from
TextBox1_Changeand now catching two different events:LostFocusandKeyDownin 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
感谢@PeterT，我在@PeterT 的指导下更正了代码，并将其提供给所有感兴趣的人。 尽情享受.
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