What: balloon
 Where: ftp://ftp.procplace.com/pub/tcl/sorted/packages-7.6/devel/balloon-1.0.tar.gz
 Description: Simple Tk 4.0/4.1/4.2/8.0 library to create balloon help.
 Updated: 10/1998
 Contact: mailto:vitus@ice.ru (Victor Wagner)

----

[male] - 2003-12-15:

so many people started to develop their GUI balloons or [tooltips] and here is mine:

   * usage: '''balloon''' ''widget'' ''?option value option value ...?''
   * widget: the name of the widget to be linked
   * options:
   '''-background''':   background colour, like in all other widgets
   '''-dismissdelay''':   time to wait in miliseconds before dismissing/destroying the balloon
   '''-foreground''':   foreground colour, affecting the font colour, like in all other widgets
   '''-label''':   if given, this label text will be shown in bold and closed with a colon in the next line the balloon text will be shown
   '''-showdelay''':   time to wait in miliseconds before showing the balloon after entering the widget
   '''-text''':   text to be shown in the balloon
   '''-textvariable''': the given variable name will be used to flexiblize the text inside the balloon. It will override the option '''-text'''

   * save the source code and make a simple pkgIndex.tcl file with:
 package ifneeded balloon 1.0 [list source [file join $dir balloon.1.0.tcl]];

   * the source code:

 package provide balloon 1.0;
 
 namespace eval ::balloon {
   proc this {} "return [namespace current];";
 
   variable state;
 
   array unset state;
   array set state {};
 
   proc balloon {w args} {
     set background   lightyellow;
     set dismissdelay 5000;
     set foreground   black;
     set label        "";
     set showdelay    500;
     set text         "";
     set textvariable "";
 
     foreach {option value} $args {
       set var  [string range $option 1 end];
 
       switch -exact -- $option {
         -bg         -
         -background -
         -fg         -
         -foreground {
           if {[string match "f*" $var]} {
             set var  foreground;
           } else {
             set var  background;
           }
 
           if {[catch {winfo rgb $parent $value;}]} {
             error "expected valid $var colour name or value, but got \"$value\"";
           }
         }
         -dismissdelay -
         -showdelay    {
           if {![string is integer -strict $value]} {
             error "expected integer delay value in ms, but got \"$value\"";
           }
         }
         -label        {}
         -text         {}
         -textvariable {}
         default  {
           error "bad option \"$option\": must be -background, -dismissdelay, -foreground, -label, -showdelay, or -text";
         }
       }
 
       set $var  $value;
     }
 
     variable state;
 
     array unset state $w.*;
 
     set state($w.background)   $background;
     set state($w.foreground)   $foreground;
     set state($w.dismissdelay) $dismissdelay;
     set state($w.label)        $label;
     set state($w.showdelay)    $showdelay;
     set state($w.text)         $text;
     set state($w.textvariable) $textvariable;
 
     bind $w <Any-Enter> [list \
       after \
         $showdelay \
         [list [namespace code showCB] %W] \
     ];
     bind $w <Any-Leave> [list [namespace code destroyCB] %W];
 
     return;
   }
 
   proc destroyCB {w} {
     variable state;
 
     catch {destroy $w.balloon;};
 
     if {[info exists state($w.id)] && ($state($w.id) != "")} {
       catch {after cancel $state($w.id);};
 
       set state($w.id)  "";
     }
 
     return;
   }
 
   proc showCB {w} {
     if {[eval winfo containing [winfo pointerxy .]] != $w} {
       return;
     }
     
     variable state;
 
     set top    $w.balloon;
     set width  0;
     set height 0;
 
     catch {destroy $top;}
 
     toplevel $top \
       -relief      solid \
       -background  $state($w.foreground) \
       -borderwidth 1;
 
     wm withdraw         $top;
     wm overrideredirect $top 1;
     wm sizefrom         $top program;
     wm resizable        $top 0 0;
 
     if {$state($w.label) != ""} {
       pack [label $top.label \
         -text       $state($w.label) \
         -background $state($w.background) \
         -foreground $state($w.foreground) \
         -font       {{San Serif} 8 bold} \
         -anchor     w \
         -justify    left \
       ] -side top -fill x -expand 0;
 
       update idletasks;
 
       set width  [winfo reqwidth $top.label];
       set height [winfo reqheight $top.label];
     }
 
     if {($state($w.text) != "") ||
         ($state($w.textvariable) != "")} {
       if {$state($w.textvariable) != ""} {
         upvar 0 $state($w.textvariable) textvariable;
 
         set state($w.text) $textvariable;
       }
       
       pack [message $top.text \
         -text       $state($w.text) \
         -background $state($w.background) \
         -foreground $state($w.foreground) \
         -font       {{San Serif} 8} \
         -aspect     10000 \
         -justify    left \
       ] -side top -fill x -expand 0;
 
       update idletasks;
 
       catch {
         if {$width < [winfo reqwidth $top.text]} {
           set width [winfo reqwidth $top.text];
         }
 
         incr height [winfo reqheight $top.text];
       }
     }
 
     catch {
       update idletasks;
 
       if {[winfo pointerx $w]+$width > [winfo screenwidth $w]} {
         set x [expr {[winfo screenwidth $w] - 10 - $width}];
       } else {
         set x [expr {[winfo pointerx $w] + 10}];
       }
       
       wm geometry $top \
         ${width}x${height}+${x}+[expr {[winfo pointery $w]+10}];
       wm deiconify $top;
 
       raise $top;
 
       set state($w.id) [after \
         $state($w.dismissdelay) \
         [list [namespace code destroyCB] $w] \
       ];
     }
 
     return;
   }
 
   namespace export -clear balloon;
 }
 
 namespace import -force ::balloon::*;
 
----
[Category Package]
[Category GUI]