Вставить дату в TextBox - VBA - PullRequest
Новая
       39

Вставить дату в TextBox - VBA

0 голосов
/ 20 октября 2018

Я знаю, что мы можем использовать функцию Дата в формах для вставки даты.Но для некоторых дат (таких как история хиджры шамси и лунная история хиджры и т. Д.) Это невозможно и сложно.Поэтому я написал код, который работает с текстовым полем.Но я думаю, что код, который я написал, может быть проще.У вас есть решение, чтобы сделать это проще?Например: проверка косой черты или предотвращение отображения двойного сообщения для ошибки луны и дня.

Заранее спасибо друзьям, которые откликнулись. 

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

Ответы [ 2 ]

0 голосов
/ 22 октября 2018

Благодаря @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
0 голосов
/ 20 октября 2018

Я недостаточно знаком с календарными формами, с которыми вы имеете дело, поэтому, пожалуйста, поймите мой пример, основанный на календаре в западном стиле.

То, как вы выполняете некоторые из ваших проверок на ошибки, несколько затеняетзначения, которые вы проверяете.Например, 

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

это имеет более интуитивный смысл.Да, он создает дополнительную переменную, но делает ваш код намного более читабельным.

Вот моя (непроверенная) версия вашего кода в качестве другого примера того, как это можно сделать.Обратите внимание, что я делю проверку ошибок на отдельную функцию, потому что она более сложная.(Таким образом, он не загромождает основную подпрограмму.)

РЕДАКТИРОВАТЬ: Ответ обновлен и проверен.Изменил код события с TextBox1_Change и теперь перехватывает два разных события: LostFocus и KeyDown, чтобы начать проверку, когда пользователь щелкает по текстовому полю или вводит Введите , находясь в текстовом поле.. 

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
...