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@45.free.net (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 {}; bind $w {}; 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 [list \ after \ $showdelay \ [concat [namespace code showCB] %W] \ ]; bind $w [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) \ [list [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 1. 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. ---- [Category Package] | [Category GUI]