Here's some little helpers when dealing with widgets, originally contributed by Richard Suchenwirth and many others (see credits at items). Help yourself! Add comments if you know better! For some Tcl things, see Bag of algorithms.
Links to recipes on other pages: table of contents to recipes on this page below.
a script might ask. Just try to call a harmless Tk command:
if {[catch {tk appname}]} {
# this is tclsh
} else {
# this is wish
} ;# RSOr this- much faster. Not to say either of them are significantly slow.
if {![info exists tk_version]} {
# this is tclsh
} else {
# this is wish
} ;# FWOr the "correct" way:
if {[package provide Tk] != ""} {
# wish
} else {
# tclsh
}We had the problem on Sun boxes that the BackSpace key deleted to the right (i.e. was understood as Delete), which makes using Netscape et al. inconvenient. In Tk apps, the easy workaround was
bind Entry <Delete> [bind Entry <BackSpace>]
meaning: When in an Entry widget the Delete key is pressed, use the bindings associated with BackSpace. Same with Text.
This is a common problem with Unix workstations that results from people getting the backspace and delete keys mixed up. This can happen either because of the server implementors not understanding what is going on, them preferring to fix the brokenness of xterm using non-xterm-specific solutions, or because they try to derive the keymap from that used when in console mode (a common problem I've seen with XFree86.)
The correct way of fixing this is to install a keymap on your Xserver that makes the backspace key generate the BackSpace symbol and the delete key generate the Delete symbol. A fragment that allows you to check what symbols are being generated follows below:
pack [label .l -textvariable symbol]
bind . <Key> {set symbol "You pressed the %K key"}Once you've got the keymap installed, you might have trouble with your terminal emulators inserting ^H characters (xterm is particularly bad in this respect.) You fix this by adding a setting to the terminal emulator that causes the correct key sequence (usually the \x7f character) to be sent instead.
FYI, this is one of my personal bugbears. I have been banging my head against this particular brick wall for years, and I lost count long ago of the number of people who simply insist on fixing this the wrong way. Even after you've explained it all to them in excruciating detail. AARRGGHH!!
DKF
The red, green and blue weigh in at different rates. The following proc returns relative "luminosity", 1.0 for white, 0.0 for black:
proc brightness color {
foreach {r g b} [winfo rgb . $color] break
set max [lindex [winfo rgb . white] 0]
expr {($r*0.3 + $g*0.59 + $b*0.11)/$max}
} ;#RS, after [Kevin Kenny]Replace the RGB factors with 0.6, -0.28, -0.32 for "in-phase", 0.21, -0.52, 0.31 for "quadrature" components of the color subcarrier, if you need them.
You can fine-tune button height with e.g.
$b configure -pady 0 -borderwidth 1
Just experiment with different pady and borderwidth arguments to find the best settings. This way, you're still ready when your product goes Japanese.
by Markus Pietrek on comp.lang.tcl (RWT)
toplevel .child
set parent .
set child .child
# This should display $child centered in $parent
set w [winfo width $parent]
set h [winfo height $parent]
set x [winfo rootx $parent]
set y [winfo rooty $parent]
set xpos "+[ expr {$x+($w-[winfo width $child])/2}]"
set ypos "+[ expr {$y+($h-[winfo height $child])/2}]"
wm geometry $child "$xpos$ypos"For iconizing management (and placing $child in front of $parent), try
wm transient $child $parent wm group $child $parent
DKF - Many people prefer to use [format] to generate their geometry specs; like this:
set childX [expr {$x+($w-[winfo width $child])/2}]
set childY [expr {$y+($h-[winfo height $child])/2}]
wm geometry $child [format "+%d+%d" $childX $childY]This has the advantage of being (in many people's eyes) appreciably clearer, since it expresses what is actually meant, as opposed to just being a way that works most of the time.
It also has the advantage (for some earlier versions of the 8.0.* series at least) of allowing you to put in extra checks for the unpleasant case of where you are trying to map a window to the left or off the top of the screen (which was not permitted in those buggy versions.) I can remember being fairly baffled by this bug when I first hit it (demonstrating my application to my boss on his laptop, of course! Ahem...)
jnc Dec 8, 2009: Undocumented but available since at least 8.4 is tk::PlaceWindow. To use it, simply call tk::PlaceWindow $child widget $parent. That's all. It has the smarts to wait until the window is mapped and not to put the window over the screen edge.
proc clock:set var {
global $var
set $var [clock format [clock seconds] -format %H:%M:%S]
after 800 [list clock:set $var]
}
pack [label .l -textvariable myclock]
clock:set myclock ;# call once, keeps ticking ;-) RSUsing after 800 makes it ticking in 0,8 sec. intervals then it looks like it stops for 1,6 seconds ( in fact showing the same second two times) and starts again ticking too fast. Simply use after 1000 to fix this. ;-) CMG
This produces an RGB color name for a number between 0 and 100, starting at red for 0, orange, yellow for 50, bright green, full green for 100. Useful for painting progressbars ;-)
proc color:ryg n {
# map 0..100 to a red-yellow-green sequence
if {$n<0} {set n 0} elseif {$n>100} {set n 100}
set red [expr $n>75? 60-($n*15/25) : 15]
set green [expr $n<50? $n*15/50 : 15]
format "#%01x%01x0" $red $green
} ;#RS#By George Peter Staplin
#Unix specific, unless you have top for Windows.
#I've only tested it with OpenBSD's top.
pack [frame .f -width 200 -height 32 -relief sunken -bd 2]
pack propagate .f 0
pack [frame .f.f -relief raised -width 10 -height 30 -bd 1] -side left
update
proc _readFromTopPipe {} {
global topPipe
set line [gets $topPipe]
if {[regexp "CPU.* (\[0-9\]{1,2}\\.\[0-9\]).*idle" $line all match] == 1} {
.f.f config -width [expr {((100 - $match) * ([winfo width .f] - 2)) / 100}]
}
}
set topPipe [open "|top -d infinity -u -s 1" r]
fconfigure $topPipe -blocking 0
fileevent $topPipe readable _readFromTopPipeJust gives you the sorted names of built-in cursors
proc cursor:names {} {return {
X_cursor arrow based_arrow_down based_arrow_up boat bogosity
bottom_left_corner bottom_right_corner bottom_side bottom_tee
box_spiral center_ptr circle clock coffee_mug cross
cross_reverse crosshair diamond_cross dot dotbox double_arrow
draft_large draft_small draped_box exchange fleur gobbler
gumby hand1 hand2 heart icon iron_cross left_ptr left_side
left_tee leftbutton ll_angle lr_angle man middlebutton mouse
pencil pirate plus question_arrow right_ptr right_side
right_tee rightbutton rtl_logo sailboat sb_down_arrow
sb_h_double_arrow sb_left_arrow sb_right_arrow sb_up_arrow
sb_v_double_arrow shuttle sizing spider spraycan star target
tcross top_left_arrow top_left_corner top_right_corner
top_side top_tee trek ul_angle umbrella ur_angle watch xterm
}} ;#RS# Inventing my own easy-to-handle data format. :^)
set data {
italic 1 text "H"
bold 1 text "el"
color red text "lo"
italic 0 text " w"
color blue text "or"
bold 0 text "ld"
}
set color black
set italic 0
set bold 0
set size 18
set family Times
pack [text .t]
proc getFont {} {
global italic bold size family
set options {}
if {$italic} {lappend options italic}
if {$bold} {lappend options bold}
return [list $family $size $options]
}
set font [getFont]
foreach {key element} $data {
if {$key == "text"} {
# Tagnames have a few restrictions. So use regsub to generate one
regsub -all {[- {}]} "font $font color $color" {_} tagname
.t tag configure $tagname -font $font -foreground $color
.t insert insert $element $tagname
} else {
set $key $element
set font [getFont]
}
}Here's a working doodler, courtesy of Roger E Critchlow Jr, mailto:[email protected] :
#!/usr/local/bin/wish
package require Tk
pack [canvas .c]
bind .c <ButtonPress-1> {
set %W(line) [list %W coords [%W create line %x %y %x %y] %x %y]
}
bind .c <B1-Motion> {eval [lappend %W(line) %x %y]}
bind .c <ButtonRelease-1>; {unset %W(line)}---
CLN was surprised this wasn't explained somewhere on the wiki (at least I couldn't find it). You can create one in a Tk window using [frame]:
% frame .f -height 4 -bd 2 -relief raised .f % pack .f -side top -expand 1 -fill x -pady 1c -padx 10
Sorry. I don't have a good way to put a screenshot here.
If you want to change X keystrokes to produce the character U in a text widget $w:
bind $w X {event generate . U; break}To regain the original behavior:
bind $w X {}For each keypress (from Welch 2, p. 291). Let $w be your widget, e.g. "."
bind $w <KeyPress> {puts {%%K=%K %%A=%A}}Instead of puts, you might show the keysym (K) and the printable char (A) in a label, or whatever.
Measure how long a key on the keyboard was pressed, e.g. for musical applications (courtesy bryan oakley):
focus .
bind . <Any-KeyPress> {handleKey press %K; break}
bind . <Any-KeyRelease> {handleKey release %K; break}
proc handleKey {action keysym} {
global timestamp
switch -- $action {
press {
if {![info exists timestamp($keysym)]} {
set timestamp($keysym) [clock clicks]
}
}
release {
set clicks [expr {[clock clicks] - $timestamp($keysym)}]
unset timestamp($keysym)
puts "duration of '$keysym': $clicks clicks"
}
}
}Note that this isn't perfect; if you hold down the "Z" key and then press a shift key, bad things will happen...
A spin-off of http://www.man.ac.uk/~zzcgudf/tcl/#games/maze
Note that the code tags the created items with the tag lcd and will delete any existing items with that tag. To have the LCD numbers anywhere except the top-left of the (unscrolled) canvas, you will need to move the items with the lcd tag...
# The shapes of individual elements of a digit
array set lcdshape {
a {3.0 5 5.2 3 7.0 5 6.0 15 3.8 17 2.0 15}
b {6.3 2 8.5 0 18.5 0 20.3 2 18.1 4 8.1 4}
c {19.0 5 21.2 3 23.0 5 22.0 15 19.8 17 18.0 15}
d {17.4 21 19.6 19 21.4 21 20.4 31 18.2 33 16.4 31}
e {3.1 34 5.3 32 15.3 32 17.1 34 14.9 36 4.9 36}
f {1.4 21 3.6 19 5.4 21 4.4 31 2.2 33 0.4 31}
g {4.7 18 6.9 16 16.9 16 18.7 18 16.5 20 6.5 20}
}
# Which elements are turned on/off for a given digit?
foreach {digit onElems offElems} {
0 {a b c d e f} {g}
1 {c d} {a b e f g}
2 {b c e f g} {a d}
3 {b c d e g} {a f}
4 {a c d g} {b e f}
5 {a b d e g} {c f}
6 {a b d e f g} {c}
7 {b c d} {a e f g}
8 {a b c d e f g} {}
9 {a b c d e g} {f}
- {g} {a b c d e f}
{ } {} {a b c d e f g}
} {
set lcdelems(on-$digit) $onElems
set lcdelems(off-$digit) $offElems
}
# Displays a decimal number using LCD digits in the top-left of the canvas
proc showLCD {w num {width 5} {colours {#ff8080 #ff0000 #404040 #303030}}} {
global lcdshape lcdelems
set lcdoffset 0
$w delete lcd
foreach {onRim onFill offRim offFill} $colours {break}
foreach glyph [split [format %${width}d $num] {}] {
foreach symbol $lcdelems(on-$glyph) {
$w move [eval $w create polygon $lcdshape($symbol) -tags lcd \
-outline $onRim -fill $onFill] $lcdoffset 0
}
foreach symbol $lcdelems(off-$glyph) {
$w move [eval $w create polygon $lcdshape($symbol) -tags lcd \
-outline $offRim -fill $offFill] $lcdoffset 0
}
incr lcdoffset 22
}
}With text widget, courtesy Kano (mailto:[email protected] ) on 1999-05-17: I've seen people asking for more customizable listboxes, and I was bored, so just:
pack [elist .widgetname -same options -as a -text widget]
.widgetname tag configure choice -options for -the selected -text index
.widgetname insert end "list item 1\n" {tags such as color}I just whipped this up real quick and decided to post it. Enjoy.. =) (I apologize for the indentation; my newsreader messed it up; RS tried to fix it)
proc elist {widget args} {
eval text [list $widget] $args
$widget configure -cursor arrow
bindtags $widget [list $widget elist all]
return $widget
}
bind elist <Button-1> {elist_do select %W %x %y;break}
bind elist <B1-Motion> {elist_do select %W %x %y;break}
bind elist <Key-Up> {elist_do moveselect %W -1;break}
bind elist <Key-Up> {elist_do moveselect %W 1;break}
proc elist_do {cmd widget args} {
switch -glob -- $cmd {
select {elist_do setselect $widget @[join $args ,]}
moveselect {;#elist_do setselect $widget [expr [?] ?]}
setselect {
$widget tag remove choice 1.0 end
$widget tag add choice "[lindex $args 0] linestart" \
"[lindex $args 0] lineend + 1 char"
}
rem* - del* {
incr args
$widget delete "$args.0" "$args.end + 1 char"
}
}
}(I fished this out from DejaNews, the moveselect clause seems to be broken there - RS)
Undocumented, but maybe helpful, posted by Cameron Laird. If your customer wants the messagebox to appear at a certain screen position:
tkMessageBox ... set w .__tk__messagebox wm geometry $w ...
Works only in Linux/Unix, and then in this modified scheme:
after idle wm geometry .... ;tk_messageBox
Bryan Oakley responded in comp.lang.tcl on how to make a button as small as possible: You can get it down to at least two pixels by turning off all the borders and giving it a 1x1 image.
% image create photo -width 1 -height 1 image1 % button .b -image image1 -borderwidth 0 -highlightthickness 0 -padx 0 -pady 0 .b % winfo width .b 2 % winfo height .b 2
This was posted by Jeffrey Hobbs on comp.lang.tcl, in response to the question: "Is there a list of color names to RGB values. ie. Black -> #000"
# dec2rgb --
#
# Takes a color name or dec triplet and returns a #RRGGBB color.
# If any of the incoming values are greater than 255,
# then 16 bit value are assumed, and #RRRRGGGGBBBB is
# returned, unless $clip is set.
#
# Arguments:
# r red dec value, or list of {r g b} dec value or color name
# g green dec value, or the clip value, if $r is a list
# b blue dec value
# clip Whether to force clipping to 2 char hex
# Results:
# Returns a #RRGGBB or #RRRRGGGGBBBB color
#
proc dec2rgb {r {g 0} {b UNSET} {clip 0}} {
if {![string compare $b "UNSET"]} {
set clip $g
if {[regexp {^-?(0-9)+$} $r]} {
foreach {r g b} $r {break}
} else {
foreach {r g b} [winfo rgb . $r] {break}
}
}
set max 255
set len 2
if {($r > 255) || ($g > 255) || ($b > 255)} {
if {$clip} {
set r [expr {$r>>8}]; set g [expr {$g>>8}]; set b [expr {$b>>8}]
} else {
set max 65535
set len 4
}
}
return [format "#%.${len}X%.${len}X%.${len}X" \
[expr {($r>$max)?$max:(($r<0)?0:$r)}] \
[expr {($g>$max)?$max:(($g<0)?0:$g)}] \
[expr {($b>$max)?$max:(($b<0)?0:$b)}]]
}You can get the beginnings of a simple editor for text that is entered right-to-left (for languages like Hebrew and Arabic) by using an ordinary text widget. All you need to do is:
pack [text .txt -wrap none] -fill both -expand 1
.txt insert insert "\t"
.txt mark gravity insert left
set charwidth [font measure [.txt cget -font] "M"]
set rightMargin [expr {[.txt cget -width] * $charwidth}]
.txt conf -tab [list $rightMargin r]
focus .txtIt isn't perfect, of course, but it does go to demonstrate the surprising power of the text widget!
DKF
For normal text widget by Bruce Gingery [L2 ] for Tcl 7.6/Tk 4.2 and up
foreach e [bind Text] {
bind ROText $e [bind Text $e]
}
# With bindings copied, now modify
bind ROText <Tab> [bind Text <Control-Tab>]
bind ROText <Shift-Tab> [bind Text <Control-Shift-Tab>]
bind ROText <Return> [bind Text <Down>]
bind ROText <<Cut>> [bind Text <<Copy>>]
bind ROText <space> [bind Text <Next>]
bind ROText <Shift-space> [bind Text <Prev>]
foreach b [list <Delete> <BackSpace> <<Paste>> <<Clear>> \
<Control-h> <<PasteSelection>> <Insert> <KeyPress> \
<Control-d> <Control-i> <Control-k> <Control-t> <Meta-d> \
<Control-o> <Meta-BackSpace> <Meta-Delete> \
] {
bind ROText $b { #nothing }
}
# Now, create a text anywhere:
toplevel .mywin
pack text .mywin.t
# And turn it into a ROText by
bindtags .mywin.t [list .mywin.t ROText . all]
#or bindtags .mywin.t [list .mywin.t ROText .mywin . all]For any widget (after code in Welch book):
proc scrolled {type name args} {
# decorate a widget with discreet scrollbars
# warning: returns name of "type" widget, which is != "name"
# usage example: set c [scrolled canvas .foo -width 200 -height 100]
frame $name
$type $name.$type \
-xscrollcommand [list scroll? $name.x \
[list grid $name.x -row 1 -column 0 -sticky we]]\
-yscrollcommand [list scroll? $name.y \
[list grid $name.y -row 0 -column 1 -sticky ns]]
eval $name.$type configure $args
scrollbar $name.x -ori h -command "$name.$type xview"
scrollbar $name.y -ori v -command "$name.$type yview"
grid $name.$type $name.y -sticky news
grid $name.x -sticky news
grid rowconfigure $name 0 -weight 1
grid columnconfigure $name 0 -weight 1
return $name.$type
}
proc scroll? {bar cmd offset size} {
# scrollbars come and go as needed -- see Welch 8.0/347f.
if {$offset != 0.0 || $size != 1.0} {
eval $cmd
$bar set $offset $size
} else {
[lindex $cmd 0] forget $bar
}
}KBK: But see also Scroll bars that appear only when needed for a solution that allows the scrollbars to be gridded arbitrarily and therefore avoids the auxiliary frame.
DKF - see also enhanced version at Scrolling widgets without a text or canvas wrapper
# Make our contents and a list of frame names...
for {set i 0} {$i<15} {incr i} {
set w .lb$i
frame $w
listbox $w.lb -xscrollcommand "$w.x set" -yscrollcommand "$w.y set"
scrollbar $w.x -command "$w.lb xview" -takefocus 0 -width 10 \
-orient horizontal
scrollbar $w.y -command "$w.lb yview" -takefocus 0 -width 10
$w.lb insert end "LISTBOX $i" "A: This is listbox $i" \
"B: This is listbox $i" "C: This is listbox $i" \
"D: This is listbox $i" "E: This is listbox $i"
grid $w.lb $w.y -sticky nsew
grid $w.x -sticky ew
grid columnconfigure $w 0 -weight 1
grid rowconfigure $w 0 -weight 1
lappend lbs $w
}
# How many frames to show at once?
set width 4
# Our primary scrollbar
scrollbar .sb -command "doScroll" -orient horizontal -width 20
# And set up the static parts of the geometry manager
grid .sb -row 1 -columnspan $width -sticky ew
for {set i 0} {$i<$width} {incr i} {
grid columnconfigure . $i -weight 1
after idle grid columnconfigure . $i -minsize \[winfo reqwidth .lb0]
}
grid rowconfigure . 0 -weight 1
after idle grid rowconfigure . 0 -minsize \[winfo reqheight .lb0]
# We start at the left...
set pos 0
proc reconf {} {
global pos lbs width
.sb set [expr {double($pos)/([llength $lbs])}] \
[expr {double($pos+$width)/([llength $lbs])}]
eval grid forget $lbs
eval grid [lrange $lbs $pos [expr {$pos+$width-1}]] -row 0
}
proc Xscroll {n units} {
global pos width
switch $units {
units {incr pos $n}
pages {incr pos [expr {$n*$width}]}
}
}
proc Xmoveto {fraction} {
global pos lbs
set pos [expr {int([llength $lbs]*$fraction)}]
}
proc doScroll {args} {
global pos lbs width
set oldpos $pos
set len [expr {[llength $lbs]-$width}]
eval X$args
if {$pos<0} {set pos 0} elseif {$pos>$len} {set pos $len}
if {$pos != $oldpos} {reconf}
}
# Set up the scrollbar and frames...
reconfMarty Backe
Often it's necessary to bind keystrokes to buttons. For instance, pressing the Return key might activate the default button in a display. A simplistic approach would be to use the button's built-in 'flash' method. This is unsatisfactory. The user should see the affected button behave as if the mouse was used to press the button. That is, the button should depress and then release.
This small procedure will perform that action for any button. If your program is within a namespace, use the appropriate variable and command scoping instead of the global variables/proc's I'm using here:
proc pressbutton { button {mode 0}} {
if {$mode == 1} {
$button configure -relief raised
set ::_flashdone 0
} else {
$button configure -relief sunken
after 100 [list pressbutton $button 1]
vwait ::_flashdone
}
}In use, you would call this method to press the button, followed by the button's 'invoke' method.
set activateButton [.button1 -text "Activate" -command puts "Pressed"}] pack $activeButton pressbutton $activateButton $activateButton invoke
Defaults to the Tcl Powered logo. PSE
proc Splash { { art tclpower.gif } { delay 2500 } { artdir "" } } {
catch { [ winfo ] } errmsg
if { [ string match invalid* $errmsg ] } {
return -code error "Splash requires Tk"
}
set logo [file join $artdir $art]
if { [ file exists $logo ] } {
frame .splash -borderwidth 4 -relief raised
set logo [ image create photo -file $logo ]
label .splash.logo -image $logo
pack .splash.logo -fill both
place .splash -anchor c -relx .5 -rely .5
after $delay destroy .splash
update
} else {
set msg "Too Bad, splash logo missing!\n"
append msg "(file: \"$logo\" not found)"
puts $msg
}
return {}
}ulis, 2004-02-13. A splash proc that uses a toplevel to let the user the ability to fill the main window. And an optional delay parameter to let the user the ability to destroy the splash from outside the proc.
proc splash {imgfile {delay 0}} {
wm withdraw .
toplevel .splash
wm overrideredirect .splash 1
canvas .splash.c -highlightt 0 -border 0
if {[catch {image create photo splash -file $imgfile}]} {
error "image $imgfile not found"
}
.splash.c create image 0 0 -anchor nw -image splash
foreach {- - width height} [.splash.c bbox all] break
.splash.c config -width $width -height $height
set wscreen [winfo screenwidth .splash]
set hscreen [winfo screenheight .splash]
set x [expr {($wscreen - $width) / 2}]
set y [expr {($hscreen - $height) / 2}]
wm geometry .splash +$x+$y
pack .splash.c
raise .splash
update
if {$delay > 0} {
after $delay {destroy .splash; wm deiconify .}
}
}usage: splash file ?delay?
If delay is omitted, the user has to destroy .splash and deiconify . later.
pack [text .t]
.t tag configure superscript -offset 5
.t insert end 2 {} 2 superscriptFrom a newspost by Bryan Oakley. Subscript should have a negative offset. Hints for improving: The amount (here: 5) should depend on the normal text pointsize. The sub/superscripted text could be set to half that pointsize -- RS More detail on the subject of subscripting appears in posts [L3 ] by KBK, Jeffrey Hobbs, and others.
The command after 1000 holds everything up until the delay time has expired. Here is an active delay with a default 100ms:
proc waiter {{millisec 100}} {
global waiter
set waiter 0
after $millisec {incr waiter}
tkwait variable waiter
return
}
# example usage
waiter 500A similar principle gives a stepping control, useful for debugging, with the bonus of a coloured button indicating its state:
proc stepper {} {
global stepper
if {![info exists stepper]} {
set stepper 0
pack [button .stepper -text "Step" -command {incr stepper} -bg green]
}
.stepper configure -bg red
tkwait variable stepper
.stepper configure -bg green
update idletasks
return
}
# example usage
stepper ;# ready
stage 1
stepper ;# midway
stage 2
stepper ;# finished
exitRRL
A few procs to handle default buttons (that is, which button gets invoked if you press Return in a toplevel outside a widget that makes use of Return). These need to be wrapped up in a namespace, etc. but I'm looking for feedback on this 'draft'. - Chris mailto:[email protected]
# Procs to handle default button for a toplevel.
#---------------------------------------------------------------------
# Get a list of all buttons in a toplevel
proc allDefaultableButtons { w } {
set widgets [winfo children [winfo toplevel $w]]
set buttons {}
while {[llength $widgets]} {
set w [lindex $widgets 0]
set widgets [lrange $widgets 1 end]
eval lappend widgets [winfo children $w]
if {
[string equal [winfo class $w] Button] &&
![string equal [$w cget -default] disabled]
} {
lappend buttons $w
}
}
return $buttons
}
#---------------------------------------------------------------------
# Make sure only one button in a toplevel has default active
proc fixDefault { w } {
if {[string equal [winfo class $w] "Button"]} {
foreach b [allButtons $w] {
$b configure -default normal
}
$w configure -default active
}
}
#---------------------------------------------------------------------
# Invoke the default button in a toplevel
proc invokeDefault { w } {
catch {
foreach b [allButtons $w] {
if {[string equal [$b cget -default] "active"]} {
$b invoke
}
}
}
}
#---------------------------------------------------------------------
# Set up a top level window to have default buttons handled.
proc handleDefaultForTopLevel { w } {
# Make sure buttons in this toplevel have default enabled
option add $w*Button*Default normal widgetDefault
# When focus changes in this toplevel, fix the default button.
bind $w <FocusIn> [list + fixDefault %W]
# When the user presses Return in this top level, invoke the
# default button.
bind $w <KeyPress-Return> [list + invokeDefault $w]
}DKF - altered this to only do default management among buttons that don't have it explicitly disabled; it is possible to have dialogs with groups of buttons that are never going to be defaults as well as groups that are defaults.
However much screen real estate Tk alotted for the window, limit the window to that size. Ideal for keeping oblivious people (and here I refer to Windows users-- just kidding, don't hurt me) from shrinking windows and making widgets disappear.
proc limit {window} {
wm minsize $window [winfo width $window] [winfo height $window]
} ;# FWIf you care to make the window freely resizable again, just use:
wm minsize $window 0
Helmut Giese explains an interesting effect: disabled widgets that don't appear disabled. Achieve this by setting the disabled color to the active color. He posted the example
$chkBx configure -disabledforeground \
[$chkBx cget -activeforeground]When would one want this, though? ["To make the label easier to read ..."] One could also try unavailable appearance
# needed only to move the original command
namespace eval ::ttk::scrollableframe {}
proc ::ttk::scrollableframe {w args} {
frame $w -class TScrolledframe
set c [canvas $w.canvas \
-borderwidth 0 \
-highlightthickness 0 \
-background [style lookup "." -background]]
pack $c -expand 1 -fill both
set f [frame $w.canvas.frame]
$c create window {0 0} -window $f -anchor nw
bind $c <<ThemeChanged>> {
%W configure -background [ttk::style lookup . -background]
}
bind $f <Configure> [list $c configure -scrollregion {0 0 %w %h}]
bind $c <Destroy> [list rename ::$w {}]
set opts {
-xscrollcommand
-yscrollcommand
-xscrollincrement
-yscrollincrement
}
dict set map getframe [list ::apply {{f} {return $f}} $f]
dict set map xview [list ::apply {{c args} {$c xview {*}$args}} $c]
dict set map yview [list ::apply {{c args} {$c yview {*}$args}} $c]
dict set map cget [list ::apply {{c opts option} {
if {$option ni $opts} {
return -code error "unknown option \"$option\""
}
$c cget $option
}} $c $opts]
dict set map configure [list ::apply {{c opts args} {
switch -- [llength $args] {
0 {
set result [list]
set conflist [$c configure]
foreach option $opts {
lappend result [lsearch -inline $conflist ${option}*]
}
return $result
}
1 {
set option [lindex $args 0]
if {$option in $opts} {
return [$c configure $option]
} else {
return -code error "unknown option \"$option\""
}
}
default {
dict for {option value} $args {
if {$option in $opts} {
$c configure $option $value
} else {
return -code error "unknown option \"$option\""
}
}
}
}
} } $c $opts]
dict set map see [list ::apply {{c widget {vert top} {horz left}} {
scan [winfo geometry $widget] "%dx%d+%d+%d" w h xo yo
lassign [$c cget -scrollregion] -> -> Xo Yo
if {$vert eq "bottom"} {
set yo [expr {$yo - [winfo height $c] + $h}]
}
if {$horz eq "right"} {
set xo [expr {$xo - [winfo width $c] + $w}]
}
set yfrac [expr {double($yo) / $Yo}]
set xfrac [expr {double($xo) / $Xo}]
$c xview moveto $xfrac
$c yview moveto $yfrac
} } $c]
rename ::$w ::ttk::scrolledframe::$w
namespace ensemble create \
-command ::$w \
-map $map
::$w configure {*}$args
return $w
}
# needed only to move the original command
namespace eval ::ttk::scrolledwindow {}
proc ::ttk::scrolledwindow {w} {
frame $w -class TScrolledwindow
scrollbar $w.sy -orient vertical
scrollbar $w.sx -orient horizontal
grid $w.sy -row 0 -column 1 -sticky ns
grid $w.sx -row 1 -column 0 -sticky ew
grid columnconfigure $w 0 -weight 1
grid rowconfigure $w 0 -weight 1
grid remove $w.sx $w.sy
bind $w.sy <Destroy> [list rename ::$w {}]
set lambdaterm {{scrollbar from to} {
if {$from == 0.0 && $to == 1.0} {
grid remove $scrollbar
} else {
grid $scrollbar
}
$scrollbar set $from $to
}
}
dict set map setwidget [list ::apply {{w lambdaterm widget} {
set old [grid slaves $w -row 0 -column 0]
if {$old ne ""} {
grid forget $old
}
grid $widget -in $w -sticky news -row 0 -column 0
$widget configure \
-xscrollcommand [list apply $lambdaterm $w.sx] \
-yscrollcommand [list apply $lambdaterm $w.sy]
$w.sx configure -command [list $widget xview]
$w.sy configure -command [list $widget yview]
} } $w $lambdaterm]
rename ::$w ::ttk::scrolledwindow::$w
namespace ensemble create \
-command ::$w \
-map $map
return $w
}#Code by Rani Ahmad (superlinux)
#!/usr/bin/wish
proc flashing { label_path delay number_of_repeats label_text} {
if { $number_of_repeats % 2 == 0 } {
#case when the state is OFF
$label_path configure -text " "
} else {
#case when the state is ON
$label_path configure -text $label_text
}
if { $number_of_repeats != 0 } {
incr number_of_repeats -1
after $delay " flashing $label_path $delay $number_of_repeats $label_text"
} else {
$lab configure -text ""
}
}
#example usage of the procedure
#start with empty text label ".mylabel"
label .mylabel -text ""
pack .mylabel
#flash every half a second
set flash_every_microseconds 500
#let it flash 10 times and display the message "warning".
set number_of_repeats 10
set message warning
flashing .mylabel $flash_every_microseconds $number_of_repeats $messageAMG: See also: A scrolled frame.