Updated 2018-04-30 11:56:48 by foo ▲

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.

  • Dial Widget, turn a knob to adjust a scalar value - by [Roger E Critchlow Jr]

  • Entry Validation, examples of entry widget validation routines for Tk 8.3 and higher

  • Keyboard widget lots of buttons in a frame, inserting its associated character to a text widget. Unicodes welcome! RS

Page contents
 Am I running in a wish?
 Backspace going the right way
 Brightness of a color
 Buttons appearing too big:
 Center Window on Parent
 Clock display on label
 Colors from percent
 CPU Usage Meter:
 Cursor names:
 Formatted text insertion in the text widget
 Freehand drawing on canvas
 Horizontal rule
 Keybindings modified
 Keybindings reported
 Keypress duration
 LCD/LED number display for a canvas
 Listbox substitute
 Messagebox geometry
 Minimal buttons:
 RGB Colors from Names or Decimal Values
 Right-to-Left Text Entry
 ROText Binding
 Scrollbars when needed
 Scrolling widgets without a text or canvas wrapper
 Simulating button presses
 Splash Screen
 Sub-/Superscripts in text widget:
 tkwait for active delay and stepping controls
 Handle default buttons
 Keeping users from hiding elements resizing windows
 Disabled widgets that don't appear disabled
 Scrolled window and scrollable frame
 Flashing and blinking the text of [label] widget

Am I running in a wish?

a script might ask. Just try to call a harmless Tk command:
if {[catch {tk appname}]} {
    # this is tclsh
} else {
    # this is wish
} ;# RS

Or this- much faster. Not to say either of them are significantly slow.
if {![info exists tk_version]} {
    # this is tclsh
} else {
    # this is wish
} ;# FW

Or the "correct" way:
if {[package provide Tk] != ""} {
    # wish
} else {
    # tclsh
}

Backspace going the right way

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

Brightness of a color

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.

Buttons appearing too big:

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.

Center Window on Parent

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.

Clock display on label

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 ;-) RS

Using 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

Colors from percent

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

CPU Usage Meter:

#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 _readFromTopPipe

Cursor names:

Just 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

Formatted text insertion in the text widget

by Donal Fellows
# 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]
    }
}

Freehand drawing on canvas

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)}

---

Horizontal rule

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.

Keybindings modified

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 {}

Keybindings reported

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.

Keypress duration

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...

LCD/LED number display for a canvas

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
    }
}

Listbox substitute

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)

Messagebox geometry

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

Minimal buttons:

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

RGB Colors from Names or Decimal Values

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)}]]
}

Right-to-Left Text Entry

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 .txt

It isn't perfect, of course, but it does go to demonstrate the surprising power of the text widget!

DKF

ROText Binding

For normal text widget by Bruce Gingery [2] 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]

Scrollbars when needed

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.

Scrolling widgets without a text or canvas wrapper

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...
reconf

Simulating button presses

Marty 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

Splash Screen

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.

Sub-/Superscripts in text widget:

pack [text .t]
.t tag configure superscript -offset 5
.t insert end 2 {} 2 superscript

From 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 [3] by KBK, Jeffrey Hobbs, and others.

tkwait for active delay and stepping controls

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 500

A 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
exit

RRL

Handle default buttons

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.

Keeping users from hiding elements resizing windows

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]
} ;# FW

If you care to make the window freely resizable again, just use:
wm minsize $window 0

Disabled widgets that don't appear disabled

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

Scrolled window and scrollable frame

# 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
}

Flashing and blinking the text of [label] widget

#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 $message

AMG: See also: A scrolled frame.

Tk examplesArts and crafts of Tcl-Tk programmingCategory ExampleCategory GUI