excel - 在文本框中插入日期 - VBA

Question

我知道我们可以使用函数日期在用于插入日期的表格中。但对于某些日期(如 Hijri Shamsi 和 Hijri lunar history 等)，这是不可能和困难的。所以我写了一个适用于文本框的代码。但我认为我写的代码可以更简单。你有解决方案让它更简单吗？
例如:检查斜线或防止月日错误的双重信息显示。

先谢谢回复的 friend 。

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

我对您处理的日历表格不够熟悉，所以请理解我基于西式日历的示例。

您执行某些错误检查的方式在某种程度上掩盖了您正在检查的值。例如，

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