Updated 2016-01-30 00:58:19 by pooryorick

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:[email protected] (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. If zero, than the balloon will be disabled. If -1, the tooltip will be deleted.
-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

  • calling balloon on a widget more than once, configures or deletes the balloon
  • 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} {
     variable state;
 
     if {[info exists state($w.background)]} {
       foreach var [array names $w.*] {
         set [lindex [split $var "."] end] $state($var);
       }
     } else {
       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;
     }
 
     array unset state $w.*;
 
     if {$showdelay == -1} {
       bind $w <Any-Enter> {};
       bind $w <Any-Leave> {};
       return;
     }

     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;
 
 # FIX by [Vitus Wagner]
    if {$showdelay} {
      bind $w <Any-Enter> [list \
         after \
           $showdelay \
           [concat [namespace code showCB] %W] \
       ];
       bind $w <Any-Leave> [concat [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;}

    if {!$state($w.showdelay)} {
      return;
    }
 
     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) \
         [concat [namespace code destroyCB] $w] \
       ];
     }
 
     return;
   }
 
   namespace export -clear balloon;
 }
 
 namespace import -force ::balloon::*;

Vitus Wagner, 28 april 2004

There is a bug in the posted code - events should be bound if $showdelay variable is NOT zero, so exlacmation mark should be removed. See "FIX by Vitus Wagner" comment.

There is also one misfeature - packages intended for reuse should NEVER NEVER NEVER hardcode -font option.

I recommend following changes:

  1. When creating toplevel, add -class Balloon
  2. Remove -font options everywhere and replace all of them with

one command
  option add *Balloon*Font {"Sans Serif" 8 bold} widgetDefault

somewhere in the code.

Then user of the package can override font using option add command. This also allows to override balloon fonts just for some widgets, using path specification.

BTW, it doesn't look like my code. Somebody have overhauled it, adding namespace support.

I think that I should make newer release (with proper option database support) and post it on http://45.free.net/~vitus/software/tcl (ZB 2010-01-03 Dead link)

Bezoar 10-04-2011

updated code int bindings to use concat rather than list to eliminate invalid command error.