Version 44 of Bag of Tk algorithms

Updated 2008-12-23 01:32:13 by HJG

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.

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


Balloon help, (a.k.a. tooltips), minimalist version

  proc balloon {w help} {
    bind $w <Any-Enter> "after 1000 [list balloon:show %W [list $help]]"
    bind $w <Any-Leave> "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:[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)}

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


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 . <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 navigation by keyboard


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)


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 [L1 ] 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]

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 <Key>    [list destroy $w]
   bind $w <Button> [list destroy $w]
   bind $w <Motion> [list destroy $w]
   return $w
 }

Unix/X only (and you need to have a screensaver installed - it works for me on CDE...) DKF

 exec xset s activate

RS: Sure, but the idea was to have a Tk widget in which to insert the real fun animations, or whatever, in Tcl ;-)


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 [L2 ] 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


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

If 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


Tk examples - Arts and crafts of Tcl-Tk programming