Version 3 of Balloon Help, Generalised

Updated 2006-08-22 11:17:03

if 0 {

From Example Scripts Everybody Should Have I've taken the balloon help and improved such that it

• looks like the tooltips of Win (yellow background, 1 px black outline),
• balloon msg appears at mouse pointer, not at center of window,
• tooltip position does not extend physical screen,
• sets ballon msgs not only to widgets but also on text tags and canvas ids, (see example at end)
• removes bindings from canvas ids by leaving the msg blank,
• if text contains [ and ], then its contents are evaluated, so that e.g. on Text widgets, the msg can be created dynamically depending on the current content

Benefits:

1. Covers widgets as well as text tags as well as canvas ids
2. Not more than two procedures spoiling the namespace.
3. More flexible because a subst call is done on the msg text.

Caveats:

1. Widget name .balloonHelp used, so this name cannot be used elsewhere;
2. if events <Enter> and <Leave> are in use otherwise, no balloon help.

Have fun!

 }

 #!/usr/local/bin/wish

 package require Tk

 proc setBalloonHelp {w msg args} {
     array set opt [concat {
         -tag ""
     } $args]
     if {$msg ne ""} then {
         set toolTipScript\
             [list showBalloonHelp %W [string map {% %%} $msg]]
         set enterScript [list after 1000 $toolTipScript]
         set leaveScript [list after cancel $toolTipScript]
         append leaveScript \n [list after 200 [list destroy .balloonHelp]]
     } else {
         set enterScript {}
         set leaveScript {}
     }
     if {$opt(-tag) ne ""} then {
         switch -- [winfo class $w] {
             Text {
                 $w tag bind $opt(-tag) <Enter> $enterScript
                 $w tag bind $opt(-tag) <Leave> $leaveScript
             }
             Canvas {
                 $w bind $opt(-tag) <Enter> $enterScript
                 $w bind $opt(-tag) <Leave> $leaveScript
             }
             default {
                 bind $w <Enter> $enterScript
                 bind $w <Leave> $leaveScript
             }
         }
     } else {
         bind $w <Enter> $enterScript
         bind $w <Leave> $leaveScript
     }
 }

 proc showBalloonHelp {w msg} {
     set t .balloonHelp
     catch {destroy $t}
     toplevel $t -bg black
     wm overrideredirect $t yes
     if {$::tcl_platform(platform) == "macintosh"} {
         unsupported1 style $t floating sideTitlebar
     }
     pack [label $t.l -text [subst $msg] -bg yellow -font {Helvetica 9}]\
         -padx 1\
         -pady 1
     set width [expr {[winfo reqwidth $t.l] + 2}]
     set height [expr {[winfo reqheight $t.l] + 2}]
     set xMax [expr {[winfo screenwidth $w] - $width}]
     set yMax [expr {[winfo screenheight $w] - $height}]
     set x [winfo pointerx $w]
     set y [expr {[winfo pointery $w] + 20}]
     if {$x > $xMax} then {
         set x $xMax
     }
     if {$y > $yMax} then {
         set y $yMax
     }
     wm geometry $t +$x+$y
     set destroyScript [list destroy .balloonHelp]
     bind $t <Enter> [list after cancel $destroyScript]
     bind $t <Leave> $destroyScript
 }

 # demo
 if true {
     pack [button .b -text tryme -command {puts "you did it!"}]
     #
     setBalloonHelp .b "Text that describes\nwhat the button does"
     #
     pack [text .t -width 30 -height 5] -expand yes -fill both
     .t insert end abcDEFghi 
     .t tag configure yellow -background yellow
     .t tag add yellow 1.1 1.6
     #
     setBalloonHelp .t "Colorised Text" -tag yellow
     #
     pack [canvas .c] -expand yes -fill both
     set id [.c create rectangle 10 10 100 100 -fill white]
     #
     setBalloonHelp .c {Geometry: [.c coords $::id]} -tag $id
 }