AW: Datum in Textbox vereinfacht eingeben
31.12.2019 08:44:27
Nepumuk
Hallo Werner,
teste mal:
Option Explicit
Private mblnChange As Boolean
Private Sub CommandButton1_Click()
Dim intTag As Integer, intMonat As Integer, intJahr As Integer
Dim strYear As String
With TextBox1
If .TextLength > 5 And .TextLength < 10 Then
strYear = Left$(CStr(Year(Date)), 10 - .TextLength) & Mid$(.Text, 7)
If MsgBox("Das Jahr war unvollständig und wird" & vbLf & "automatisch in das Jahr " _
& strYear & " konvertiert.", vbOKCancel, "Datumskorrektur") = vbCancel Then
.SelStart = 6
.SelLength = 10 - .TextLength
.SetFocus
Exit Sub
Else
.Text = Left$(.Text, 6) & Left$(CStr(Year(Date)), 10 - .TextLength) & Mid$(.Text, 7)
End If
End If
If .TextLength = 10 Then
On Error GoTo err_exit
intTag = Cint(Mid$(.Text, 1, 2))
intMonat = Cint(Mid$(.Text, 4, 2))
intJahr = Cint(Mid$(.Text, 7, 4))
Select Case intMonat
Case 4, 6, 9, 11
If intTag > 30 Then
MsgBox "Der Monat " & MonthName(intMonat) & " hat nur 30 Tage", vbExclamation, "Hinweis"
.Text = Right$(.Text, 8)
.SelStart = 0
.SetFocus
Exit Sub
End If
Case 2
If intJahr Mod 4 = 0 And (intJahr Mod 100 <> 0 Xor intJahr Mod 400 = 0) Then
If intTag > 29 Then
MsgBox "Der Monat Februar hat im Jahr " & CStr(intJahr) & _
" nur 29 Tage", vbExclamation, "Hinweis"
.Text = Right$(.Text, 8)
.SelStart = 0
.SetFocus
Exit Sub
End If
Else
If intTag > 28 Then
MsgBox "Der Monat Februar hat im Jahr " & CStr(intJahr) & _
" nur 28 Tage", vbExclamation, "Hinweis"
.Text = Right$(.Text, 8)
.SelStart = 0
.SetFocus
Exit Sub
End If
End If
End Select
Else
If .TextLength = 0 Then
MsgBox "Bitte ein Datum eingeben.", vbExclamation, "Hinweis"
Else
MsgBox "Das eingegebene Datum ist nicht korrekt.", vbExclamation, "Hinweis"
.SelStart = 0
.SelLength = .TextLength
End If
.SetFocus
Exit Sub
End If
'Datum in Tabelle schreiben
With Worksheets(1).Cells(1, 1)
.NumberFormat = "dd.mm.yyyy"
.Value = CDate(TextBox1.Text)
End With
CommandButton2.Value = True
Exit Sub
err_exit:
MsgBox "Das eingegebene Datum ist nicht korrekt.", vbExclamation, "Hinweis"
.SelStart = 0
.SelLength = .TextLength
End With
End Sub
Private Sub CommandButton2_Click()
Call Unload(Object:=Me)
End Sub
Private Sub TextBox1_Change()
If Not mblnChange Then
With TextBox1
If Len(.Text) = 2 Then .Text = .Text & "."
If Len(.Text) = 5 Then .Text = .Text & "."
End With
End If
End Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
With TextBox1
If KeyCode = 8 And (.TextLength = 3 Or .TextLength = 6) Then
mblnChange = True
.Text = Left$(.Text, .TextLength - 1)
End If
End With
mblnChange = False
End Sub
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Select Case KeyAscii
Case 42 To 45: KeyAscii = 46
Case 46, 48 To 57
Case Else: KeyAscii = 0
End Select
If KeyAscii <> 0 Then
With TextBox1
Select Case .TextLength
Case 0
If KeyAscii > 51 Then
.Text = "0" & Chr$(KeyAscii)
KeyAscii = 0
ElseIf KeyAscii = 46 Then
KeyAscii = 0
End If
Case 1
If KeyAscii = 46 Then
KeyAscii = 0
If .Text <> "0" Then .Text = "0" & .Text
Else
If Right$(.Text, 1) = "3" And KeyAscii > 49 Then KeyAscii = 0
End If
Case 3
If KeyAscii = 46 Then KeyAscii = 0
If KeyAscii > 49 Then .Text = .Text & "0"
Case 4
If KeyAscii = 46 Then
KeyAscii = 0
If Right$(.Text, 4) <> "0" Then .Text = Left$(.Text, 3) & "0" & Right$(.Text, 1)
Else
If Right$(.Text, 1) <> "0" And KeyAscii > 50 Then KeyAscii = 0
End If
Case 5 To 9
If KeyAscii = 46 Then KeyAscii = 0
Case 10
KeyAscii = 0
End Select
End With
End If
End Sub
Gruß
Nepumuk