[Keith Vetter] 2002-02-20 : 
I recently needed a datefield widget but didn't want to include the whole iwidget package. So, I just took the iwidget datefield code and modified to work under 
tcl only. This is part of [TkLib].


[KPV] 2004-12-02 : I've modified the code to allow various different
date formats via an optional '''-format <fmt>''' option. The format must
five characters long and be of the form: ''AxByC'' where ABC is some
ordering of "y", "m" and "d" and xy are any two separator characters.
Some common format strings include: ''m/d/y'', ''m-d-y'', ''y/m/d'',
''y:m:d''.

[ofv] 2005-11-24 : This widget is hardly usable for certain date formats. For instance, when the widget shows 10-02-2005 (in d-m-y format) and the user wants 31-12-2005, overwriting '10' with '31' gives '28' as the day, as the too-smart widget knows that February has not 31 days. You are forced to first edit the month, go backwards and edit the day. Confusing and annoying. I'm afraid ``validate-on-focus-exit'' is the only cure for this.

----

 ##+##########################################################################
 #
 # datefield.tcl
 #
 # Implements a datefield entry widget ala Iwidget::datefield
 # by Keith Vetter
 #
 # Datefield creates an entry widget but with a special binding to
 # KeyPress to ensure that the current value is always a valid date.
 # All normal entry commands and configurations still work.
 #
 # Usage:
 #  ::datefield::datefield <widget> ?-format y/m/d?
 #
 # Example Usage:
 #  ::datefield::datefield .df -format m/d/y -bg yellow -textvariable myDate
 #  pack .df
 #
 # Formats: format must be 5 characters long and of the form: AxByC
 # where ABC is some ordering of "y", "m" and "d" and xy are two
 # arbitrary separator characters. Some valid formats include:
 # m/d/y, m-d-y, y/m/d, y:m:d
 #
 # Bugs:
 #   o won't work if you programmatically put in an invalid date
 #     e.g. .df insert end "abc"    will cause it to behave erratically
 #
 # Revisions:
 # KPV Feb 07, 2002 - initial revision
 # KPV Oct 09, 2002 - Made to understand multiple fixed-length formats
 # Ferenc Engard Jan 11, 2004 - fixed tab handling, focus in and home/end
 # KPV Dec 02, 2004 - allow multiple simultaneous formats
 #
 ##+##########################################################################
 #############################################################################
 
 namespace eval ::datefield {
    namespace export datefield
    variable instanceID 0
    variable pos
    variable DEFAULT
    variable FORMATS
 
    array set DEFAULT {format "y/m/d"}
    array set FORMATS {
        mdy {0  2    3  5    6 10 10 "%m/%d/%Y"}
        myd {0  2    8 10    3  7 10 "%m/%Y/%d"}
        dmy {3  5    0  2    6 10 10 "%d/%m/%Y"}
        dym {8 10    0  2    3  7 10 "%d/%Y/%m"}
        ymd {5  7    8 10    0  4 10 "%Y/%m/%d"}
        ydm {8 10    5  7    0  4 10 "%Y/%d/%m"}
    }
 
    proc datefield {w args} {
        variable pos
        variable instanceID
 
        set id [incr instanceID]
        for {set i 1} {$i < $id} {incr i} {     ;# Garbage collect
            if {[info exists pos($i,widget)] && ! [winfo exists $pos($i,widget)]} {
                catch {array unset pos $i,*}
            }
        }
 
        set args [processArgs $id $args]
        set pos($id,widget) $w
        eval entry $w -width 10 -justify center $args
        $w insert end [clock format [clock seconds] -format $pos($id,cformat)]
        $w icursor 0
 
        bind $w <KeyPress> [list ::datefield::dfKeyPress $id $w %A %K %s]
        bind $w <FocusIn> "$w selection clear; $w icursor 0"
        bind $w <Button1-Motion> break
        bind $w <Button2-Motion> break
        bind $w <Double-Button>  break
        bind $w <Triple-Button>  break
        bind $w <2>              break
 
        return $w
    }
    proc processArgs {id arglist} {
        variable pos
        variable DEFAULT
        variable FORMATS
 
        foreach arg [array names DEFAULT] {     ;# Process options we care about
            set opts($arg) $DEFAULT($arg)
            set n [lsearch $arglist "-$arg"]
            if {$n == -1} continue
 
            set opts($arg) [lindex $arglist [expr {$n + 1}]]
            set arglist [lreplace $arglist $n [expr {$n + 1}]]
        }
 
        if {[string length $opts(format)] != 5} {
            error "xunknown date format \"$opts(format)\""
        }
        foreach {a sep1 b sep2 c} [split $opts(format) ""] break
        set nformat [string tolower "$a$b$c"]
 
        if {! [info exists FORMATS($nformat)]} {
            error "unknown date format \"$opts(format)\""
        }
        if {[string is integer $sep1] || [string is integer $sep2]} {
            error "illegal date format \"$opts(format)\""
        }
        foreach var [list m1 m2 d1 d2 y1 y2 len cformat] f $FORMATS($nformat) {
            set pos($id,$var) $f
        }
        regsub {/} $pos($id,cformat) $sep1 pos($id,cformat)
        regsub {/} $pos($id,cformat) $sep2 pos($id,cformat)
 
        return $arglist
    }
 
    # internal routine for all key presses in the datefield entry widget
    proc dfKeyPress {id w char sym state} {
        variable pos
        set icursor [$w index insert]
 
        # Handle some non-number characters first
        if {$sym == "plus" || $sym == "Up" || \
                $sym == "minus" || $sym == "Down"} {
            set dir "1 day"
            if {$sym == "minus" || $sym == "Down"} {
                set dir "-1 day"
            }
            set base [clock scan [Normalize $id $w]]
            if {[catch {set new [clock scan $dir -base $base]}] != 0} {
                bell
                return -code break
            }
            set xdate [clock format $new -format "%m/%d/%Y"]
            if {[catch {clock scan $xdate}]} {
                bell
                return -code break
            }
            $w delete 0 end
            $w insert end [clock format $new -format $pos($id,cformat)]
            $w icursor $icursor
            return -code break
        } elseif {$sym == "Right" || $sym == "Left" || $sym == "BackSpace" || \
                $sym == "Delete"} {
            set dir -1
            if {$sym == "Right"} {set dir 1}
 
            set icursor [expr {($icursor+$pos($id,len) + $dir) % $pos($id,len)}]
            ;# Don't land on a slash
            if {$icursor == $pos($id,m2) || $icursor == $pos($id,d2) \
                    || $icursor == $pos($id,y2)} {
                set icursor [expr {($icursor+$pos($id,len)+$dir)%$pos($id,len)}]
            }
            $w icursor $icursor
            return -code break
        } elseif {($sym == "Control_L") || ($sym == "Shift_L") || \
                ($sym == "Control_R") || ($sym == "Shift_R")} {
            return -code break
        } elseif {$sym == "Home"} {
            $w icursor 0
            return -code break
        } elseif {$sym == "End"} {
            $w icursor end
            return -code break
        } elseif {$sym == "Tab" || $sym == "ISO_Left_Tab"} {;# Tab key
            return -code continue               ;# Just leave the widget
        } elseif {$sym == "Tab" && ($state & (0x01 + 0x04)) == 0} {;# Tab key
            if {$icursor == $pos($id,len)} {return -code continue}
 
            if {$icursor >= $pos($id,m1) && $icursor < $pos($id,m2)} {
                set cursor $pos($id,m2)
            } elseif {$icursor >= $pos($id,d1) && $icursor < $pos($id,d2)} {
                set cursor $pos($id,d2)
            } else {
                set cursor $pos($id,y2)
            }
            if {[incr cursor] >= $pos($id,len)} {
                return -code continue           ;# Tabbed out of the widget
            }
            $w icursor $cursor
            return -code break
        } elseif {$sym == "Tab" && ($state && (0x01 + 0x04)) != 0} {
            return -code continue               ;# Just leave the widget
            set cursor -1
            if {$icursor > $pos($id,m2) && $pos($id,m1) > $cursor} {set cursor $pos($id,m1)}
            if {$icursor > $pos($id,d2) && $pos($id,d1) > $cursor} {set cursor $pos($id,d1)}
            if {$icursor > $pos($id,y2) && $pos($id,y1) > $cursor} {set cursor $pos($id,y1)}
            if {$cursor < 0} {
                return -code continue           ;# Tabbed out of the widget
            }
            $w icursor $cursor
            return -code break
        }
 
        if {! [regexp {[0-9]} $char]} {         ;# Unknown character
            bell
            return -code break
        }
 
        if {$icursor >= $pos($id,len)} {        ;# Can't add beyond end
            bell
            return -code break
        }
        foreach {month day year} [split [Normalize $id $w] "/"] break
        #puts "[$w get] => [Normalize $id $w] = $month/$day/$year"
        # MONTH SECTION
        if {$icursor >= $pos($id,m1) && $icursor < $pos($id,m2)} {
            #puts "in month"
            foreach {m1 m2} [split $month ""] break
            set cursor [expr {$pos($id,m2) + 1}] ;# Where to leave the cursor
 
            if {$icursor == $pos($id,m1)} {     ;# 1st digit of month
                if {$char < 2} {
                    set month "$char$m2"
                    set cursor [expr {$pos($id,m1) + 1}]
                } else {
                    set month "0$char"
                }
                if {$month > 12} {set month 10}
                if {$month == "00"} {set month "01"}
            } else {                            ;# 2nd digit of month
                set month "$m1$char"
                if {$month > 12} {set month "0$char"}
                if {$month == "00"} {
                    bell
                    return -code break
                }
            }
            $w delete $pos($id,m1) $pos($id,m2)
            $w insert $pos($id,m1) $month
 
            # Validate the day of the month
            if {$day > [set endday [lastDay $month $year]]} {
                $w delete $pos($id,d1) $pos($id,d2)
                $w insert $pos($id,d1) $endday
            }
            $w icursor $cursor
 
            return -code break
        }
        # DAY SECTION
        if {$icursor >= $pos($id,d1) && $icursor < $pos($id,d2)} {
            #puts "in day"
            set endday [lastDay $month $year]
            foreach {d1 d2} [split $day ""] break
            set cursor [expr {$pos($id,d2) + 1}] ;# Where to leave the cursor
 
            if {$icursor <= $pos($id,d1)} {     ;# 1st digit of day
                if {$char < 3 || ($char == 3 && $month != "02")} {
                    set day "$char$d2"
                    if {$day == "00"} { set day "01" }
                    if {$day > $endday} {set day $endday}
                    set cursor [expr {$pos($id,d1) + 1}]
                } else {
                    set day "0$char"
                }
            } else {                            ;# 2nd digit of day
                set day "$d1$char"
                if {$day > $endday || $day == "00"} {
                    bell
                    return -code break
                }
            }
            $w delete $pos($id,d1) $pos($id,d2)
            $w insert $pos($id,d1) $day
            $w icursor $cursor
            return -code break
        }
 
        # YEAR SECTION
        #puts "in year"
        set y1 [string index $year 0]
        if {$icursor == $pos($id,y1)} {         ;# 1st digit of year
            if {$char != "1" && $char != "2"} {
                bell
                return -code break
            }
            if {$char != $y1} {                 ;# Different century
                set y 1999
                if {$char == "2"} {set y 2000 }
                $w delete $pos($id,y1) $pos($id,y2)
                $w insert $pos($id,y1) $y
            }
            $w icursor [expr {$pos($id,y1) + 1}]
            return -code break
        }
        $w delete $icursor
        $w insert $icursor $char
        if {[catch {clock scan [Normalize $id $w]}] != 0} { ;# Validate year
            $w delete $pos($id,y1) $pos($id,y2)
            $w insert $pos($id,y1) $year        ;# Put back in the old year
            $w icursor $icursor
            bell
            return -code break
        }
        if {$icursor == $pos($id,y2)-1} {
            $w icursor [expr {$icursor + 2}]
        }
        return -code break
    }
    # internal routine that returns the last valid day of a given month and year
    proc lastDay {month year} {
        set days [clock format [clock scan "+1 month -1 day" \
                      -base [clock scan "$month/01/$year"]] -format %d]
    }
    proc Normalize {id w} {
        variable pos
        set date [$w get]
        set m [string range $date $pos($id,m1) [expr {$pos($id,m2) - 1}]]
        set d [string range $date $pos($id,d1) [expr {$pos($id,d2) - 1}]]
        set y [string range $date $pos($id,y1) [expr {$pos($id,y2) - 1}]]
        return "$m/$d/$y"
    }
 }
 
 ################################################################
 ################################################################
 
 
 #
 # DEMO CODE
 #
 catch {. config -padx 10 -pady 10}
 
 set tests {"default" "y/m/d"  "m/d/y" "d/m/y"}
 set id 0
 foreach fmt $tests {
    incr id
    label .l$id -text "Format: $fmt => "
    if {$fmt eq "default"} {
        ::datefield::datefield .e$id
    } else {
        ::datefield::datefield .e$id -format $fmt
    }
    grid .l$id .e$id -pady 10
 }
 
 focus .e1

----
[Category Package] | [Category Widget] | [Category Date and Time]