Updated 2015-12-11 16:33:49 by AMG

Richard Suchenwirth - Here's a popup toplevel that displays a given month and allows to pick a date (or cancel):

Nice. A couple of comments (that I might just implement myself when/if I get the time):

  • I'd really like to see the month name - RS: brings in i18n problems, though - month numbers are so universal...

CLN, 2001-06-22: Yes, but I thought 8.4 was going to have i18n date support in clock so either mc March or clock format with % for the month name should work. No?

KBK, 27 June 2001: Alas, I've run out of time for 8.4. Internationalizing clock is a bigger job than it looks at first. I'll try to get it done over the summer.

  • I find partial weeks frustrating. The first week of this month should be: 27 28 29 30 31 1 2 - RS: ... but marked in a different color, maybe gray?

''CLN, 2001-06-22: Yes, a different color. I'm not sure how to choose one. LV, 2001-Jun-22: Why not choose something Tk-ish, but use the option database so that it could be overridden.

  • It would be nice if it accomodated European weekday ordering with Saturday and Sunday at the end, not split (that is, M,T,W,T,F,S,S, not S,M,T,W,T,R,S).
  • I'd like clicking a date to select it and close the dialog. Easy: add "set date::res $date::date" to the <1> binding - RS

Sorry to whine. It really does look nice but I've thought about this a lot and have strong opinions. -- CLN

Most of this wish list has now been fulfilled in An i15d date chooser

Feel free to add in your changes - that's one of the nice things about the wiki. In particular, if you are going to add in the month names, perhaps you will add them in a way that permits one to configure the language used to convey the months? Configuration is what I will probably be thinking about (after I think about what it will take to build a parallel widget for selecting time.

Unfortunately, my coding skills are such that one should not hold their breath waiting on me to write the time widget.
 package require Tk
 namespace eval date {
    option add *Button.padX 0
    option add *Button.padY 0
    proc choose {} {
        variable month; variable year; variable date
        variable canvas; variable res
        variable day
        set year [clock format [clock seconds] -format "%Y"]
        scan [clock format [clock seconds] -format "%m"] %d month
        scan [clock format [clock seconds] -format "%d"] %d day
        toplevel .chooseDate -bg white
        wm title .chooseDate "Choose Date:"
        frame .chooseDate.1
        entry .chooseDate.1.1 -textvar date::month -width 3 -just center
        button .chooseDate.1.2 -text ^ -command {date::adjust 1 0}
        button .chooseDate.1.3 -text v -command {date::adjust -1 0}
        entry .chooseDate.1.4 -textvar date::year -width 4 -just center
        button .chooseDate.1.5 -text ^ -command {date::adjust 0 1}
        button .chooseDate.1.6 -text v -command {date::adjust 0 -1}
        eval pack [winfo children .chooseDate.1] -side left \
                -fill both
        set canvas [canvas .chooseDate.2 -width 160 -height 160 -bg white]
        frame .chooseDate.3
        entry .chooseDate.3.1 -textvar date::date -width 10
        button .chooseDate.3.2 -text OK -command {set date::res $date::date}
        button .chooseDate.3.3 -text Cancel -command {set date::res {}}
        eval pack [winfo children .chooseDate.3] -side left
        eval pack [winfo children .chooseDate]
        display
        vwait ::date::res
        destroy .chooseDate
        set res
    }
    proc adjust {dmonth dyear} {
        variable month; variable year; variable day
        set year  [expr {$year+$dyear}]
        set month [expr {$month+$dmonth}]
        if {$month>12} {set month 1; incr year}
        if {$month<1} {set month 12; incr year -1}
        if {[numberofdays $month $year]<$day} {
            set day [numberofdays $month $year]
        }
        display
    }
    proc display {} {
        variable month; variable year
        variable date; variable day
        variable canvas
        $canvas delete all
        set x0 20; set x $x0; set y 20
        set dx 20; set dy 20
        set xmax [expr {$x0+$dx*6}]
        foreach i {S M T W T F S} {
            $canvas create text $x $y -text $i -fill blue
            incr x $dx
        }
        scan [clock format [clock scan $month/1/$year] \
                -format %w] %d weekday
        set x [expr {$x0+$weekday*$dx}]
        incr y $dy
        set nmax [numberofdays $month $year]
        for {set d 1} {$d<=$nmax} {incr d} {
            set id [$canvas create text $x $y -text $d -tag day]
            if {$d==$day} {$canvas itemconfig $id -fill red}
            incr x $dx
            if {$x>$xmax} {set x $x0; incr y $dy}
        }
        $canvas bind day <1> {
            set item [%W find withtag current]
            set date::day [%W itemcget $item -text]
            set date::date "$date::month/$date::day/$date::year"
            %W itemconfig day -fill black
            %W itemconfig $item -fill red
        }
        set date "$month/$day/$year"
    }
    proc numberofdays {month year} {
        if {$month==12} {set month 1; incr year}
        clock format [clock scan "[incr month]/1/$year  1 day ago"] \
                -format %d
    }
 } ;# end namespace date

 #------ test and demo code (terminate by closing the main window)
 while 1 {
     set date [date::choose]
     puts $date
 }

2001-06-22 RS: stepping through months does not check for day validity, so you may get dates like 2/31/1999. Fixed in proc adjust.

2003-03-06 David Bigelow: Added the ability to change fonts, highlight weights, and included rectangles around each weekday and date within the canvas - so it looks more like a calendar.

BTW - Nice job on this Tcl Code - it is impressive!

2003-03-07 David Bigelow: Updated the modified Code to act more like a widget. The "choose" command was altered to accept the path of the widget that launches it (e.g., button). The Calendar selection will popup in a relative position to the widget that you use to launch it.

To select a date, Double Click on the desired date, and the formatted date string will be returned by the "choose" function.

BTW - Special Thanks for Bryan Oakley for pointing out the vwait to me during the debugging process.

Hope everyone finds this a useful and productive widget.

Dave
 namespace eval date {
        set defaultFont {Arial 10 normal}
    option add *Button.padX 0
    option add *Button.padY 0
    option add *Button.font $defaultFont
    option add *Entry.font $defaultFont
    variable canvasFont $defaultFont
    variable canvasHighlight {Arial 11 bold}
    variable canvasHeader {Arial 14 bold}
    variable w .cal
    
    proc choose {bpath} {
        variable month; variable year; variable date
        variable canvas; variable res
        variable day
        set year [clock format [clock seconds] -format "%Y"]
        scan [clock format [clock seconds] -format "%m"] %d month
        scan [clock format [clock seconds] -format "%d"] %d day
                set w $date::w
        catch {destroy $w}
        toplevel $w -bg white
        wm transient $w $bpath
        
        set sx [expr [winfo rootx $bpath] + 15]
                set sy [expr [winfo rooty $bpath] + 5]
                wm geometry $w "+$sx+$sy"
        
        wm title $w "Choose Date:"
        
        frame $w.1
        entry $w.1.1 -textvar date::month -width 3 -just center
        button $w.1.2 -text ^ -command {date::adjust 1 0}
        button $w.1.3 -text v -command {date::adjust -1 0}
        entry $w.1.4 -textvar date::year -width 4 -just center
        button $w.1.5 -text ^ -command {date::adjust 0 1}
        button $w.1.6 -text v -command {date::adjust 0 -1}
        eval pack [winfo children $w.1] -side left -fill both
        set canvas [canvas $w.2 -width 160 -height 160 -bg white]
 # Uncomment the following to include additional controls
 #         frame $w.3
 #         entry $w.3.1 -textvar date::date -width 10
 #         button $w.3.2 -text OK -command {set date::res $date::date}
 #         button $w.3.3 -text Cancel -command {set date::res {}}
 #         eval pack [winfo children $w.3] -side left
        eval pack [winfo children $w]
        display
        vwait ::date::res
        destroy $w
        set res
    }
    
    proc adjust {dmonth dyear} {
        variable month; variable year; variable day
        set year  [expr {$year+$dyear}]
        set month [expr {$month+$dmonth}]
        if {$month>12} {set month 1; incr year}
        if {$month<1} {set month 12; incr year -1}
        if {[numberofdays $month $year]<$day} {
            set day [numberofdays $month $year]
        }
        display
    }
    
    proc display {} {
        variable month; variable year
        variable date; variable day
        variable canvas
        $canvas delete all
        set x0 20; set x $x0; set y 20
        set dx 20; set dy 20
        set xmax [expr {$x0+$dx*6}]
        foreach i {S M T W T F S} {
            $canvas create text $x $y -text $i -fill blue -font $date::canvasHeader
                        $canvas create rectangle [expr $x-10] [expr $y-10] [expr $x+10] [expr $dy+10] -fill grey90 -tags boxes
            incr x $dx
        }
        scan [clock format [clock scan $month/1/$year] \
                -format %w] %d weekday
        set x [expr {$x0+$weekday*$dx}]
        incr y $dy
        set nmax [numberofdays $month $year]
        for {set d 1} {$d<=$nmax} {incr d} {
            set id [$canvas create text $x $y -text $d -font $date::canvasFont -tag day]
             switch $x {
                20 -
                140 {set fillColor pink1}
                default {set fillColor bisque1}
            }
                        $canvas create rectangle [expr $x-10] [expr $y-10] [expr $x+10] [expr $y+10] -fill $fillColor -tags boxes
            if {$d==$day} {$canvas itemconfig $id -fill red -font $date::canvasHighlight}
            incr x $dx
            if {$x>$xmax} {set x $x0; incr y $dy}
        }
        
        $canvas lower boxes

        $canvas bind day <1> {
            set item [%W find withtag current]
            set date::day [%W itemcget $item -text]
            set date::date "$date::month/$date::day/$date::year"
            %W itemconfig day -fill black -font $date::canvasFont
            %W itemconfig $item -fill red -font $date::canvasHighlight
        }
        $canvas bind day <Double-Button-1> {
            set item [%W find withtag current]
            set date::day [%W itemcget $item -text]
            set date::date "$date::month/$date::day/$date::year"        
                set date::res $date::date
       }
    }

    proc numberofdays {month year} {
        if {$month==12} {set month 1; incr year}
        clock format [clock scan "[incr month]/1/$year  1 day ago"] \
                -format %d
    }
        
 } ;# end namespace date

 # -- DEMONSTRATION CODE -- 
 # Show a TextBox to Display Results
 pack [text .tb] -expand y -fill both
 pack [button .calendar -text "Pick Date" -command {
                                # Note: date::choose {Object to Refernece for Window Position}
                                .tb insert end "SELECTED: [date::choose .calendar]\n"
                                }]
 pack [button .ex -text "Exit" -bg red -fg white -command {exit}]

JDG: Here is a modification I made to the buttons in the date chooser. IMHO, it's much easier to use.
wm transient $w $bpath
      
      set sx [expr [winfo rootx $bpath] + 15]
               set sy [expr [winfo rooty $bpath] + 5]
               wm geometry $w "+$sx+$sy"
      
      wm title $w "Choose Date:"
      
      frame $w.1
      entry $w.1.1 -textvar date::month -width 3 -just center
      button $w.1.2 -text "<" -command {date::adjust -1 0}
      button $w.1.3 -text ">" -command {date::adjust 1 0}
      entry $w.1.4 -textvar date::year -width 4 -just center
      button $w.1.5 -text "<" -command {date::adjust 0 -1}
      button $w.1.6 -text ">" -command {date::adjust 0 1}
      eval pack $w.1.2 $w.1.1 $w.1.3 $w.1.5 $w.1.4 $w.1.6 -side left -fill both
      # eval pack [winfo children $w.1] -side left -fill both
      set canvas [canvas $w.2 -width 160 -height 160 -bg white]
# Uncomment the following to include additional controls

I also commented out the "option add *Button" lines at the top. And, to stop it from torturing my eyes, I changed the fonts:
namespace eval date {
      set defaultFont {Helvetica 12 bold}
#   option add *Button.padX 4
#   option add *Button.padY 4
#   option add *Button.font $defaultFont
#   option add *Entry.font $defaultFont
   variable canvasFont $defaultFont
   variable canvasHighlight {Helvetica 11 bold}
   variable canvasHeader {Helvetica 14 bold}
   variable w .cal

This way, you have [ < ] 12 [ > ] [ < ] 2015 [ > ]

Like it, hate it, whatever ... just sharing. :-)

See also a calendar widget