Version 26 of balloon help

Updated 2005-08-03 13:13:16 by escargo

"Balloon help" is sometimes known as "tooltips".

Effective Tcl's example code ( http://sf.net/projects/efftcl/ ) [L1 ] as well as Jeffrey Hobbs's widget library [L2 ] include a balloonhelp.tcl

[Where is its documentation?]

Bwidgets have balloons under the title of "Dynamic help", here's an example how simple that can be (RS):

    interp alias {} help {} DynamicHelp::register
    Button .f.open -image $im(open) -command {starDOM::openFile .t}
    help .f.open balloon "Open existing XML file"

Tix has a ballon widget: see http://tix.sourceforge.net/man/html/TixCmd/tixBalloon.htm


[Also describe the section in the M&M book.]

This Wiki also has a related page under the title "Balloon", and this was from the bag of Tk algorithms:

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)

GPS: I know from experience with earlier balloon code that the code has a problem. If the $help string contains % then you will probably experience weird problems. The way to fix this is to use string map to double % if they exist.

tclol:

 # dont try this at home:
 balloon .b "hey \[you\] }{ )( $ %"

I would rather do it using a global variable to store the help text. Generally I avoid having text in after or callback scripts. More, using a global can be useful for debugging or translating.

I modified the balloons script above. Move the help/ folder in directory lindex $tcl_pkgPath 0

# you can replace 'help' with 'balloon' # i keep the balloon for my quick black dog jumping over lazy foxes

help/pkgIndex.tcl:

 package ifneeded help 1.0 [list source [file join $dir help.tcl]]

help/help.tcl:

 namespace eval ::help {
   namespace export set
   variable delay 1000
 }

 proc help::set {widget txt} {
   variable help
   ::set help($widget) $txt
   bind $widget <Enter> {after $help::delay [list help::show %W]}
   bind $widget <Leave> {destroy %W.help}
 }

 proc help::show {widget} {

   variable help

   if {[eval winfo containing [winfo pointerxy .]]!=$widget} {return}

   ::set w $widget.help
   catch {destroy $w}
   toplevel $w -bd 1 -bg black
   wm overrideredirect $w 1
   if {$::tcl_platform(platform) == "macintosh"} {
    unsupported1 style $w floating sideTitlebar
   }

   pack [message $w.txt -aspect 10000 -bg lightyellow -font fixed -text $help($widget)]

   ::set wmx [winfo rootx $widget]
   ::set wmy [expr [winfo rooty $widget]+[winfo height $widget]]
   wm geometry $w [winfo reqwidth $w.txt]x[winfo reqheight $w.txt]+$wmx+$wmy
   #useless ?
   raise $w
 }
 package provide help 1.0

help/test.tcl:

 package require help
 interp alias {} help {} help::set

 button .b
 pack .b
 help .b "hey \[you\] }{ )( $ %"

EKB I made a couple of modest changes to the minimalist code (without the fixes for embedding %s and other characters). (And then later on I made modest changes to the modest changes. But when I came here to post the changes, I saw MG's nicer version below. So now I have a dilemma -- use my existing code, or switch to the nicer version? :-)

The main changes:

  • Created a namespace, "balloon" (The proc "set_balloon" is outside the namespace for my own purposes -- this way I keep the same interface in my existing programs.)
  • The "balloon delay" is adjusted so that the balloon pops up quickly if the user is scanning across sibling windows (e.g., scanning across a toolbar), and more slowly initially.
  • Adding a "+" to the start of the binding procs so that other actions that should take place as the widget is entered and exited can also take place.
 namespace eval balloon {
    variable long_delay 750
    variable short_delay 50
    variable delay $long_delay
    variable family {}
 }

 bind . <Enter> {
    if {$balloon::family != ""} {
        if {[lsearch -exact $balloon::family %W] == -1} {
            set balloon::family {}    
            set balloon::delay $balloon::long_delay
        }
    }
 }

 proc set_balloon {w help} {
    bind $w <Enter> "+after \$balloon::delay [list balloon::show %W [list $help]]; \
         set balloon::delay  $balloon::short_delay; set balloon::family \[balloon::getwfamily %W\]"
    bind $w <Leave> "+destroy %W.balloon"
 }

 # Add these to the namespace
 proc balloon::getwfamily {w} {
    return [winfo children [winfo parent $w]]
 }

 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 -padx 1 -pady 0 \
            -text $arg]
    set wmx [expr [winfo rootx $w]+5]
    set wmy [expr [winfo rooty $w]+[winfo height $w]+7]
    wm geometry $top \
      [winfo reqwidth $top.txt]x[winfo reqheight $top.txt]+$wmx+$wmy
    raise $top
 }

MG offers a slightly modified version of the above (the actual balloon code is basically identical). A few changes are:

  • The balloon code is all moved into a namespace, removing the global variables.
  • The bindings are no longer made on the widget itself - instead, they're made on a new class (if that's the right word), "Balloon", and the widget has this added at the start of its [bindtags]. That means broken bindings already set for the widget won't stop the tooltip running.
  • The text to be shown is stored in a variable (array), ::balloon::tips.
  • A few names (procs/variables) shortened, as the namespace should prevent their being overwritten by something else. The 'delay' proc is also laid out a little differently, to shorten it down.

To clear the balloon text for any widget, just set it blank (i.e., balloon $widget ""). When a widget is destroyed, its balloon text is automatically cleared from the variable via the trace command, which means if you create a new widget with the same name, it won't be carried over by mistake.

Here's the code, with a brief example script:

 namespace eval balloon {set last 0 ; namespace export balloon}

 proc ::balloon::balloon {args} {
   variable last
   variable tips

   set numArgs [llength $args]
   if { $numArgs < 1 || $numArgs > 2 } {
        return -code error "wrong # args: should be \"balloon widget ?text?\"";
      }

   set w [lindex $args 0]
   if { ![winfo exists $w] } {
        return -code error "bad window path name \"$w\""
      }

   if { [winfo class $w] == "Toplevel" } {
        return -code error "cannot create tooltip for toplevel windows";
      }

   if { $numArgs == "1" } {
        if { [info exists tips($w)] } {
             return $tips($w);
           } else {
             return "";
           }
      }

   set text [lindex $args 1]

   if { $text == "" } {
        # turn off tooltip
        if { [set x [lsearch [bindtags $w] "Balloon"]] >= 0 } {
             bindtags $w [lreplace [bindtags $w] $x $x]
           }
        unset -nocomplain tips($w)
        trace remove command $w delete ::balloon::autoclear
        return;
      }

   # OK, set up a (new?) tooltip

   if { [lsearch [bindtags $w] "Balloon"] < 0 } {
        bindtags $w [linsert [bindtags $w] 0 "Balloon"]
      }

   if { [lsearch [trace info command $w] {delete ::balloon::autoclear}] < 0 } {
        trace add command $w delete ::balloon::autoclear
      }

   set tips($w) $text

 };# balloon::balloon

 proc ::balloon::show {w} {
    variable tips
    if { ![info exists tips($w)] } {return}
    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"} {
         catch {unsupported1 style $top floating sideTitlebar}
     }
     pack [message $top.txt -aspect 10000 -bg lightyellow \
             -text $tips($w)]
     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
 };# balloon::show

 proc ::balloon::show8.5 {w} {
    variable tips
    if { ![info exists tips($w)] } {return}
    if {[winfo containing {expand}[winfo pointerxy .]]!=$w} {return}
     set top "$w.balloon"
     catch {destroy $top}
     toplevel $top -bd 1 -bg black
     bind $top <Button-1> [list destroy $top]
     wm overrideredirect $top 1
     if {$::tcl_platform(platform) == "macintosh"} {
         catch {unsupported1 style $top floating sideTitlebar}
     }
     pack [message $top.txt -aspect 10000 -bg lightyellow \
             -text $tips($w)]
     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
 };# balloon::show8.5

 if { [package vcompare [package require Tcl] 8.5] >= 0 } {
      rename ::balloon::show8.5 ::balloon::show
    } else {
      rename ::balloon::show8.5 {}
    }

 proc ::balloon::delay {} {
   variable last

   set then $last
   set last [clock seconds]
   if { [expr {$last - $then}] < 3} {
        return 50
      } else {
        return 1000
      }

 };# balloon::delay

 proc ::balloon::autoclear {old new op} {
   variable tips

   unset -nocomplain tips([namespace tail $old]);

 };# balloon::autoclear

 namespace import ::balloon::balloon
 bind Balloon <Enter> {after [::balloon::delay] [list ::balloon::show %W]}
 bind Balloon <Leave> {destroy %W.balloon}


 console show

 ##############
 # test script
 ##############
 button .b1 -text "First"  ; balloon .b1 "1st"
 button .b2 -text "Second" ; balloon .b2 "2nd"
 button .b3 -text "Third"  ; balloon .b3 "3rd"
 button .b4 -text "No tip"

 pack .b1 .b2 .b3 .b4 -side left -padx 4

 # uncomment below to clear the tooltip for "Third" button
 # balloon .b3 ""

MG Made a few modifications to the above code. You can now call it with one arg, balloon $widget, and it will return the current balloon text for that widget (or an empty string if none is set). Also, it no longer lets you set balloon text for toplevel windows, because when you do so it doesn't play nice, and gets itself into an infinite loop, which Tcl kindly catches, but still looks ugly. (I suspect that a 'break' in the <Leave> binding might sort this, but haven't bothered to check it - IMHO, not being able to tooltip a toplevel is a shame, but not being able to run custom <Leave> bindings for one is unacceptable, so it's better this way.)


Category Example | Category GUI