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]. * [A simple voltmeter] - not here, just go there. See [Dial widget] too. * Am I running in a wish? * Backspace going the right way * Balloon Help (a.k.a. tooltips) * [Bounding boxes of characters in canvases] * Brightness of a color * [Buttons with image and text] * Catching window closure * Center window on parent * Clock display in label * Colors from percent * CPU Usage Meter * Cursor names * Dial Widget * Entry Validation * Formatted text insertion in the text widget * Freehand drawing on canvas * Fully-justified text in canvas and text widgets * [A Graph Plotter] * [A little graph Plotter] * [Histogram Plotter] * HLS colors to RGB * Horizontal Rule * Keybindings modified and reported * Keyboard widget * Keypress duration * [Internal scrollbars] (Widget and accompanying scrollbar in one border) * LCD/LED number display for a canvas * Listbox navigation by keyboard * Listbox substitute with text widget * [Maximizing a toplevel window] * Menus made easy * Messagebox geometry * Minimal buttons * [Move cursor by display line in a text widget] * [Multi-column display in text widget] * NeXT-style file manager * Paning widgets allowing relative resizing * [Printing a canvas under Windows] * RGB Colors from names or decimal values * Right-to-Left text entry * RO (read-only) text binding * Screensaver * Scrollbars for any widget * [Scroll bars that appear only when needed] * Scrolling widgets without a text or canvas wrapper. * Simulating button presses * Splash Screen -- show a start-up screen for a few secs. * Subscripts and superscripts in text widget * tkwait for active delay and stepping controls * Unsorted: * proc to handle default buttons in a toplevel window * Keeping users from hiding elements resizing windows * Disabled widgets that don't appear disabled ''(kindly order the leading keywords in alphabetical order, so people have at least a small chance of finding what they are looking for... DKF)'' ---- '''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 [bind Entry ] 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 . {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''' ---- '''Balloon help''', (a.k.a. [tooltips]), minimalist version proc balloon {w help} { bind $w "after 1000 [list balloon:show %W [list $help]]" bind $w "destroy %W.balloon" } proc balloon:show {w arg} { if {[eval winfo containing [winfo pointerxy .]]!=$w} {return} set top $w.balloon catch {destroy $top} toplevel $top -bd 1 -bg black wm overrideredirect $top 1 if {$::tcl_platform(platform) == "macintosh"} { unsupported1 style $top floating sideTitlebar } pack [message $top.txt -aspect 10000 -bg lightyellow \ -font fixed -text $arg] set wmx [winfo rootx $w] set wmy [expr [winfo rooty $w]+[winfo height $w]] wm geometry $top \ [winfo reqwidth $top.txt]x[winfo reqheight $top.txt]+$wmx+$wmy raise $top } # Example: button .b -text Exit -command exit balloon .b "Push me if you're done with this" pack .b ''DAS -'' added an 'unsupported1' command to make this work on macs as well, otherwise raising the balloon window would immediately post a Leave event leading to the destruction of the balloon... The 'unsupported1' command makes the balloon window into a floating window which does not put the underlying window into the background and thus avoids the problem. (BTW, for this to work, appearance manager needs to be present, but that shouldn't be a problem for all except very old macs, otherwise you can try using the older 'unsupported1 style $top floatSideProc' although I had problems with it) ---- '''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. ---- [Buttons with image and text] - work in progress, but working... ---- Remarks on '''Catching window closure''' now appear under the more general title of "[Catching window managed events]". ---- '''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...) ---- '''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 ---- '''[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 ---- '''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:rec@elf.org : #!/usr/local/bin/wish package require Tk pack [canvas .c] bind .c { set %W(line) [list %W coords [%W create line %x %y %x %y] %x %y] } bind .c {eval [lappend %W(line) %x %y]} bind .c ; {unset %W(line)} ---- [http://www.cs.man.ac.uk/gifs/new.gif] '''Fully-justified text in canvas and text widgets''' - ''DKF'' This examples is a little too big to put on this page. See http://www.man.ac.uk/~zzcgudf/tcl/wordwrap.tcl ---- '''HLS colors to RGB''': HLS is Hue - Luminosity - Saturation, a way of specifying colors, especially useful for generating visually distinguishable colors that are then converted to the usual RGB (red green blue) representation - see [Selecting visually different RGB colors]. ---- [CLN] was surprised this wasn't explained somewhere on the wiki (at least I couldn't find it). You can create a '''horizontal rule''' 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 {puts {%%K=%K %%A=%A}} Instead of puts, you might show the keysym (K) and the printable char (A) in a label, or whatever. ---- '''[Keyboard widget]''' lots of buttons in a frame, inserting its associated character to a text widget. Unicodes welcome! ''RS'' ---- '''Keypress duration''': measure how long a key on the keyboard was pressed, e.g. for musical applications (courtesy [Bryan Oakley]): focus . bind . {handleKey press %K; break} bind . {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 navigation by keyboard]''' ---- '''Listbox substitute''' with text widget, courtesy Kano (mailto:keith@cs.oswego.edu) 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 {elist_do select %W %x %y;break} bind elist {elist_do select %W %x %y;break} bind elist {elist_do moveselect %W -1;break} bind elist {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'') ---- '''[Menus made easy]''' - specify menu structure in a simple format, let those helpers do the details ---- '''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 ... ---- '''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 ---- '''[Move cursor by display line in a text widget]''' - For word-wrapped text widgets with very long line, sometimes it is nice to move by display line, instead of by lines as the text widget knows it. ---- '''NeXT style file manager''' by [Ulf Jasper]: this code is too big to paste here. Sample screenshot: http://ulf-jasper.exit.de/ulfm/screenshot.gif from http://ulf-jasper.exit.de/ (follow the links), enjoy! ''RS'' ---- '''[Paning widgets]''' allowing relative resizing by grabbing the border, modified from code in Welch book ---- '''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] [http://tcltk.gtcs.com/] 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 [bind Text ] bind ROText [bind Text ] bind ROText [bind Text ] bind ROText <> [bind Text <>] bind ROText [bind Text ] bind ROText [bind Text ] foreach b [list <> <> \ <> \ \ \ ] { 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] ---- '''Screensaver''': here's a minimalist first shot - black screen, mouse pointer still visible, no animation. Vanishes on keypress, button press, or mouse motion. BUG?: does not hide task bar when run under NT -- does when on Sun via Reflection under NT! ''RS'' proc screensaver {w} { destroy $w ;# just to make sure toplevel $w -bg black wm overrideredirect $w 1 wm geometry $w [winfo screenwidth $w]x[winfo screenheight $w]+0+0 focus $w ;# so it gets keypresses bind $w [list destroy $w] bind $w