1# -*- tcl -*- 2# 3# dateentry.tcl - 4# 5# dateentry widget 6# 7# This widget provides an entry with a visual calendar for 8# choosing a date. It is mostly a gathering compoments. 9# 10# The basics for the entry were taken from the "MenuEntry widget" 11# of the widget package in the tklib. 12# The visual calendar is taken from http://wiki.tcl.tk/1816. 13# 14# So many thanks to Richard Suchenwirth for visual calendar 15# and to Jeff Hobbs for the widget package in tklib. 16# 17# See the example at the bottom. 18# 19# RCS: @(#) $Id: dateentry.tcl,v 1.4 2010/06/01 18:06:52 hobbs Exp $ 20# 21 22# Creation and Options - widget::dateentry $path ... 23# -command -default {} 24# -dateformat -default "%m/%d/%Y" 25# -font -default {Helvetica 9} 26# -background -default white 27# -textvariable -default {} -configuremethod C-textvariable 28# 29# Following are passed to widget::calendar component: 30# -firstday 31# -highlightcolor 32# 33# Methods 34# $widget post - display calendar dropdown 35# $widget unpost - remove calendar dropdown 36# All other methods to entry 37# 38# Bindings 39# NONE 40# 41 42### 43 44package require widget 45package require widget::calendar 46 47namespace eval ::widget { 48 # http://www.famfamfam.com/lab/icons/mini/ 49 # ?Mini? is a set of 144 GIF icons available for free use for any purpose. 50 variable dateentry_gifdata { 51 R0lGODlhEAAQAMQAANnq+K7T5HiUsMHb+v/vlOXs9IyzzHWs1/T5/1ZtjUlVa+z1/+3 52 x9uTx/6a2ysng+FFhe0NLXIDG/fD4/ykxQz5FVf/41vr8/6TI3MvM0XHG/vbHQPn8// 53 b8/4PL/f///yH5BAAAAAAALAAAAAAQABAAAAWV4Cdam2h+5AkExCYYsCC0iSAGTisAP 54 JC7kNvicPBIjkeiIyHCMDzQaFRTYH4wBY6W0+kgvpNC8GNgXLhd8CQ8Lp8f3od8sSgo 55 RIasHPGY0AcNdiIHBV0PfHQNgAURIgKFfBMPCw2KAIyOkH0LA509FY4TXn6UDT0MoB8 56 JDwwFDK+wrxkUjgm2EBAKChERFRUUYyfCwyEAOw== 57 } 58 # http://www.famfamfam.com/lab/icons/silk/ 59 # ?Silk? is a smooth, free icon set, 60 variable dateentry_gifdata { 61 R0lGODlhEAAQAPZ8AP99O/9/PWmrYmytZW6uaHOxbP+EQv+LR/+QTf+UUv+VVP+WVP+ 62 YV/+ZWP+aWv+dXP+eXf+fX/+nVP+rWv+gYP+hYf+iYv+jZP+kZP+kZf+wYf+zaP+4bf 63 +5cf+7df+9eUJ3u1KEw1SGxFWGxlaHx12KxVyKxl+MxlmKyFuKyV+NyF6Oy1+Py2OSz 64 mSTzmiW0WqX0W6Z02+b1HKe1nSg13Wh13qj2nqk2X2l3H6o3ZHBjJvHlqXNoa/Sq4Cp 65 3YOr3IKq34mu2Yyw24mw3pG03Za434Ss4Ieu4Yiv4oyx44+14Yyy5I+05ZC15pO355S 66 355W445294Zq75p++5pa66Zi66Zq865u9652+656/7KG/55/A7aTB5KTB56vG5abD6a 67 HB7qLB76rG6a7J6rLL6rfO6rrQ67zQ68PdwNfp1dji8Nvk8d7n8t7n8+Lq9Obt9urw9 68 +vx9+3y+O7z+e/z+fD0+vH2+vL2+vT3+/n8+f7+/v7//v///wAAAAAAAAAAACH5BAEA 69 AH0ALAAAAAAQABAAAAfMgH2Cg4SFg2FbWFZUTk1LSEY+ODaCYHiXmJmXNIJZeBkXFBA 70 NCwgHBgF4MoJXeBgfHh0cGxoTEgB4MIJVnxcWFREPDgwKCXgugk94X3zNzs1ecSyCTH 71 difD0FaT0DPXxcbCiCSXZjzQJpO3kFfFFqI4JHdWTnaTp8AnxFaiKCQHRl+KARwKMHA 72 W9E1KgQlIOOGT569uyB2EyIGhOCbsw500XLFClQlAz5EUTNCUE15MB546bNGjUwY5YQ 73 NCPGixYrUpAIwbMnCENACQUCADs= 74 } 75} 76 77proc ::widget::createdateentryLayout {} { 78 variable dateentry 79 if {[info exists dateentry]} { return } 80 set dateentry 1 81 variable dateentry_pngdata 82 variable dateentry_gifdata 83 set img ::widget::img_dateentry 84 image create photo $img -format GIF -data $dateentry_gifdata 85 namespace eval ::ttk [list set dateimg $img] ; # namespace resolved 86 namespace eval ::ttk { 87 # Create -padding for space on left and right of icon 88 set pad [expr {[image width $dateimg] + 6}] 89 style theme settings "default" { 90 style layout dateentry { 91 Entry.field -children { 92 dateentry.icon -side left 93 Entry.padding -children { 94 Entry.textarea 95 } 96 } 97 } 98 # center icon in padded cell 99 style element create dateentry.icon image $dateimg \ 100 -sticky "" -padding [list $pad 0 0 0] 101 } 102 if 0 { 103 # Some mappings would be required per-theme to adapt to theme 104 # changes 105 foreach theme [style theme names] { 106 style theme settings $theme { 107 # Could have disabled, pressed, ... state images 108 #style map dateentry -image [list disabled $img] 109 } 110 } 111 } 112 } 113} 114 115snit::widgetadaptor widget::dateentry { 116 delegate option * to hull 117 delegate method * to hull 118 119 option -command -default {} 120 option -dateformat -default "%m/%d/%Y" -configuremethod C-passtocalendar 121 option -font -default {Helvetica 9} -configuremethod C-passtocalendar 122 option -textvariable -default {} 123 124 delegate option -highlightcolor to calendar 125 delegate option -firstday to calendar 126 127 component dropbox 128 component calendar 129 130 variable waitVar 131 variable formattedDate 132 variable rawDate 133 variable startOnMonday 1 134 135 constructor args { 136 ::widget::createdateentryLayout 137 138 installhull using ttk::entry -style dateentry 139 140 bindtags $win [linsert [bindtags $win] 1 TDateEntry] 141 142 $self MakeCalendar 143 144 $self configurelist $args 145 146 set now [clock seconds] 147 set x [clock format $now -format "%d/%m%/%Y"] 148 set rawDate [clock scan "$x 00:00:00" -format "%d/%m%/%Y %H:%M:%S"] 149 set formattedDate [clock format $rawDate -format $options(-dateformat)] 150 151 $hull configure -state normal 152 $hull delete 0 end 153 $hull insert end $formattedDate 154 $hull configure -state readonly 155 } 156 157 method C-passtocalendar {option value} { 158 set options($option) $value 159 $calendar configure $option $value 160 } 161 162 method MakeCalendar {args} { 163 set dropbox $win.__drop 164 destroy $dropbox 165 toplevel $dropbox -takefocus 0 166 wm withdraw $dropbox 167 168 if {[tk windowingsystem] ne "aqua"} { 169 wm overrideredirect $dropbox 1 170 } else { 171 tk::unsupported::MacWindowStyle style $dropbox \ 172 help {noActivates hideOnSuspend} 173 } 174 wm transient $dropbox [winfo toplevel $win] 175 wm group $dropbox [winfo parent $win] 176 wm resizable $dropbox 0 0 177 178 # Unpost on Escape or whenever user clicks outside the dropdown 179 bind $dropbox <Escape> [list $win unpost] 180 bind $dropbox <ButtonPress> [subst -nocommands { 181 if {[string first "$dropbox" [winfo containing %X %Y]] != 0} { 182 $win unpost 183 } 184 }] 185 186 set calendar $dropbox.calendar 187 widget::calendar $calendar -command [mymethod DateChosen] \ 188 -textvariable [myvar formattedDate] \ 189 -dateformat $options(-dateformat) \ 190 -font $options(-font) \ 191 -borderwidth 1 -relief solid 192 193 pack $calendar -expand 1 -fill both 194 195 return $dropbox 196 } 197 198 method post { args } { 199 # XXX should we reset date on each display? 200 if {![winfo exists $dropbox]} { $self MakeCalendar } 201 set waitVar 0 202 203 foreach {x y} [$self PostPosition] { break } 204 wm geometry $dropbox "+$x+$y" 205 wm deiconify $dropbox 206 raise $dropbox 207 208 if {[tk windowingsystem] ne "aqua"} { 209 tkwait visibility $dropbox 210 } 211 212 ttk::globalGrab $dropbox 213 focus -force $calendar 214 return 215 216 tkwait variable [myvar waitVar] 217 218 $self unpost 219 } 220 221 method unpost {args} { 222 ttk::releaseGrab $dropbox 223 wm withdraw $dropbox 224 } 225 226 method PostPosition {} { 227 # PostPosition -- 228 # Returns the x and y coordinates where the menu 229 # should be posted, based on the dateentry and menu size 230 # and -direction option. 231 # 232 # TODO: adjust menu width to be at least as wide as the button 233 # for -direction above, below. 234 # 235 set x [winfo rootx $win] 236 set y [winfo rooty $win] 237 set dir "below" ; #[$win cget -direction] 238 239 set bw [winfo width $win] 240 set bh [winfo height $win] 241 set mw [winfo reqwidth $dropbox] 242 set mh [winfo reqheight $dropbox] 243 set sw [expr {[winfo screenwidth $dropbox] - $bw - $mw}] 244 set sh [expr {[winfo screenheight $dropbox] - $bh - $mh}] 245 246 switch -- $dir { 247 above { if {$y >= $mh} { incr y -$mh } { incr y $bh } } 248 below { if {$y <= $sh} { incr y $bh } { incr y -$mh } } 249 left { if {$x >= $mw} { incr x -$mw } { incr x $bw } } 250 right { if {$x <= $sw} { incr x $bw } { incr x -$mw } } 251 } 252 253 return [list $x $y] 254 } 255 256 method DateChosen { args } { 257 upvar 0 $options(-textvariable) date 258 259 set waitVar 1 260 set date $formattedDate 261 set rawDate [clock scan $formattedDate -format $options(-dateformat)] 262 if { $options(-command) ne "" } { 263 uplevel \#0 $options(-command) $formattedDate $rawDate 264 } 265 $self unpost 266 267 $hull configure -state normal 268 $hull delete 0 end 269 $hull insert end $formattedDate 270 $hull configure -state readonly 271 } 272} 273 274# Bindings for menu portion. 275# 276# This is a variant of the ttk menubutton.tcl bindings. 277# See menubutton.tcl for detailed behavior info. 278# 279 280bind TDateEntry <Enter> { %W state active } 281bind TDateEntry <Leave> { %W state !active } 282bind TDateEntry <<Invoke>> { %W post } 283bind TDateEntry <Control-space> { %W post } 284bind TDateEntry <Escape> { %W unpost } 285 286bind TDateEntry <ButtonPress-1> { %W state pressed ; %W post } 287bind TDateEntry <ButtonRelease-1> { %W state !pressed } 288 289package provide widget::dateentry 0.92 290 291############## 292# TEST CODE ## 293############## 294 295if { [info script] eq $argv0 } { 296 297 proc getDate { args } { 298 puts [info level 0] 299 puts "DATE $::DATE" 300 301 update 302 } 303 304 proc dateTrace { args } { 305 puts [info level 0] 306 } 307 308 # Samples 309 # package require widget::dateentry 310 set ::DATE "" 311 set start [widget::dateentry .s -textvariable ::DATE \ 312 -dateformat "%d.%m.%Y %H:%M" \ 313 -command [list getDate .s]] 314 set end [widget::dateentry .e \ 315 -command [list getDate .e] \ 316 -highlightcolor dimgrey \ 317 -font {Courier 10} \ 318 -firstday sunday] 319 grid [label .sl -text "Start:"] $start -padx 4 -pady 4 320 grid [label .el -text "End:" ] $end -padx 4 -pady 4 321 322 trace add variable ::DATE write dateTrace 323 set ::DATE 1 324 325 puts [$end get] 326} 327