Option Strict On
 
Public Class Form1
 
    Dim cval As DateTime
    Dim tc As Boolean
 
    Dim cmask As String
    Dim fields() As Integer
    Dim flengths() As Integer
    Dim cfield As Integer
    Dim cfields As Integer
    Dim maxDayLength As Integer = 10
 
    Dim showWeekDay As Boolean
 
    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As _
      System.EventArgs) Handles MyBase.Load
        showWeekDay = True
 
        cval = DateTime.Now
        cmask = "dd.mm.yyyy"
        fields = New Integer() {0, 3, 6, 255}
        flengths = New Integer() {2, 2, 4}
        cfield = 0
        cfields = 3
        maxDayLength = 10
 
        If showWeekDay Then
            cmask = New String(" "c, maxDayLength) & "." & cmask
            For i As Integer = 0 To cfields - 1
                fields(i) += maxDayLength + 1
            Next
        End If
 
        'tb.AcceptsTab = True ' Nur für Tab
        'tb.Multiline = True ' Nur für Tab
 
        setDateText()
        setField()
    End Sub
 
    Private Sub setField()
        tb.SelectionStart = fields(cfield)
        tb.SelectionLength = flengths(cfield)
    End Sub
 
    Private Sub tb_Click(ByVal sender As Object, ByVal e As System.EventArgs) _
      Handles tb.Click
        For i = 1 To cfields
            If tb.SelectionStart < fields(i) Then
                cfield = i - 1
                setField()
                Return
            End If
        Next
    End Sub
 
    Private Sub tb_KeyPress(ByVal sender As Object, ByVal e As _
      System.Windows.Forms.KeyPressEventArgs) Handles tb.KeyPress
        e.Handled = True
    End Sub
 
    Private Sub tb_KeyDown(ByVal sender As Object, ByVal e As _
      System.Windows.Forms.KeyEventArgs) Handles tb.KeyDown
        Debug.WriteLine("kd: " & e.KeyCode & " " & Hex(e.KeyCode))
        Select Case e.KeyCode
            Case Keys.Up
                UpdateValue(1)
                e.Handled = True
            Case Keys.Down
                UpdateValue(-1)
                e.Handled = True
            Case Keys.Add
                UpdateValue(1)
            Case Keys.Subtract
                UpdateValue(-1)
            Case Keys.Oemplus
                UpdateValue(1)
                e.Handled = True
            Case Keys.OemMinus
                UpdateValue(-1)
                e.Handled = True
            'Case Keys.Tab
            '    If (e.Modifiers And Keys.Shift) = Keys.Shift Then
            '        If cfield > 0 Then
            '            cfield -= 1
            '            e.Handled = True
            '        End If
            '    Else
            '        If cfield < cfields - 1 Then
            '            cfield += 1
            '            e.Handled = True
            '        End If
            '    End If
            Case Keys.Right
                If cfield < cfields - 1 Then cfield += 1
                e.Handled = True
            Case Keys.Left
                If cfield > 0 Then cfield -= 1
                e.Handled = True
        End Select
        setField()
    End Sub
 
    Private Sub UpdateValue(ByVal v As Integer)
        Dim offset As Integer = tb.SelectionStart
        If offset > cmask.Length - 1 Then offset = cmask.Length - 1
        Dim cc As Char = cmask(offset)
        Select Case cc
            Case "d"c
                cval = cval.AddDays(v)
            Case "m"c
                cval = cval.AddMonths(v)
            Case "y"c
                cval = cval.AddYears(v)
        End Select
        tc = True
        setDateText()
        tc = False
    End Sub
 
    Private Sub tb_TextChanged(ByVal sender As Object, ByVal e As _
      System.EventArgs) Handles tb.TextChanged
        If tc Then Return
        setDateText()
    End Sub
 
    Private Sub setDateText()
        Dim ss As Integer = tb.SelectionStart
        Dim sl As Integer = tb.SelectionLength
        Dim dow As String = String.Empty
        If showWeekDay Then
            ' Klappt am besten mit Courier-Schrift, ganz wie DTP kriegen wir so 
            ' nicht hin.
            Dim cc As CultureInfo = CultureInfo.CurrentCulture
            dow = cc.DateTimeFormat.DayNames(cval.DayOfWeek)
            If dow.Length < maxDayLength Then
                Dim wdl As Integer = CInt(Math.Ceiling((maxDayLength - _
                  dow.Length) / 2))
                dow = dow.PadLeft(wdl + dow.Length)
                dow = dow.PadRight(maxDayLength)
            End If
            dow &= "."
        End If
        dow &= cval.ToShortDateString()
        tb.Text = dow
        tb.SelectionStart = ss
        tb.SelectionLength = sl
    End Sub
 
End Class

________
Alle Angaben ohne Gewähr. Keine Haftung für Vorschläge, Tipps oder sonstige Hilfe, falls es schiefgeht, nur Zeit verschwendet oder man sonst nicht zufrieden ist