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...
- 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?
- 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
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 controlsI 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 .calThis way, you have [ < ] 12 [ > ] [ < ] 2015 [ > ]Like it, hate it, whatever ... just sharing. :-)See also a calendar widget
