The original code has been modified to make the tip:
-image
and -compound
options to display images-command
option to be displayed in a status bar instead of a balloon-command
option to be changed dynamically, with each tip's exposition-maxexp
option to limit the number of tip's expositionsThe video introduction to baltip is presented by baltip-1.3.1.mp4 (17 Mb).
Below are several pictures just to glance at baltip.
Under the mouse pointer. By default, the tips are displayed just under the mouse pointer.
Under the widget. This button's tip is configured to be just under the button. As well as the text's tip. This feature is well fit for widgets positioned in a row (e.g. in toolbar, tabbar etc.).
Tips of text tags. The text tags can have their own tips.
The tags of canvas have tips too.
Tips of menu items. The menu items can have their own tips. The popup menus may be tear-off at that.
The menu tips are useful e.g. when the items are displayed as short names, while the tips are wanted to be full names.
Label of danger. The labels are also tipped. This one is configured to be an alert shown "eternally" (i.e. till hovering over it).
The tabs of notebook are also supplied with tips.
The listbox
can have tips per item as well as for a whole listbox widget.
The ttk::treeview
can have tips per item and/or column as well as for a whole treeview widget.
The -command
option allows to display tips in a status bar instead of a balloon.
Configurable tips. The tip configuration can be global or local (for a specific tip).
The configuring can include: font, colors, paddings, border, relief, exposition time, opacity, image (with -compound
option), bell.
Balloon. The balloon messages aren't related to any widgets. This one is configurated to appear at the top right corner, disappearing after a while.
The baltip usage is rather straightforward. Firstly we need package require
:
lappend auto_path "dir_of_baltip" package require baltipThen we set tips with
::baltip::tip
command for each appropriate widget:
::baltip::tip widgetpath text ?-option value? # or this way: ::baltip tip widgetpath text ?-option value?For example, having a button
.win.but1
, we can set its tip this way:
::baltip tip .win.but1 "It's a tip.\n2nd line of it.\n3rd."To get all or specific settings of baltip:
::baltip::cget ?-option? # or this way: ::baltip cget ?-option?To get a specific widget's tip option:
::baltip::cget widgetpath -option # or this way: ::baltip cget widgetpath -optionTo set some options:
::baltip::configure -option value ?-option value? # or this way: ::baltip config -option value ?-option value?To set a specific widget's tip option:
::baltip::configure widgetpath -option value ?-option value? # or this way: ::baltip config widgetpath -option value ?-option value?Note: the options set with
configure
command are global, i.e. active for all tips.
The options set with tip
command are local, i.e. active for the specific tip.
To disable all tips:
::baltip::configure -on falseTo disable some specific tip:
::baltip::tip widgetpath "" # or this way: ::baltip::tip widgetpath "old tip" -on falseTo hide some specific (suspended) tip forcedly:
::baltip::hide widgetpathTo update a tip's text and options:
::baltip::update widgetpath text ?options?To show a tip for a widget that has no "normal" tip, still needs a tip (e.g. on clicking):
::baltip::showTip path text ?options?By default,
::baltip::showTip
displays the tip under the mouse pointer. At that it regards -geometry
option and ignores -under, -shiftX, -shiftY
options.
When you click on a widget with its tip being displayed, the tip is hidden. It is the default behavior of baltip, but sometimes you need to re-display the hidden tip. If the widget is a button, you can include the following command in -command
of the button:
::baltip::repaint widgetpath
The "text" for listbox
can contain %i
wildcard - and in such cases the text means a callback receiving a current index of item to tip:
proc ::lbxTip {idx} { set item [lindex $::lbxlist $idx] return "Tip for \"$item\"\nindex=$idx" } ::baltip tip .listbox {::lbxTip %i}The "text" for
ttk::treeview
can contain %i
and/or %c
wildcards - and in such cases the text means a callback receiving ID of item and/or column of item to tip:
proc ::treTip {id c} { set item [.treeview item $id -text] return "Tip for \"$item\"\nID=$id, column=$c" } ::baltip::tip .treeview {::treTip %i %c}If a tip for listbox and treeview widgets doesn't contain
%i
nor %c
, it means a usual tip for a whole widget. At that, if those wildcards still need to be displayed, use %%i
and %%c
instead.
If you need to switch between "per item" and "per widget" tip of listbox and treeview , use ::baltip::tip
with -reset yes
option:
::baltip::tip .treeview {Common tip} -reset yes ;# sets a usual tip ::baltip::tip .treeview {::treTip %i %c} -reset yes ;# sets a callbackSome GUI objects (notebook tabs, listbox items, treeview items) have not <Enter> nor <Leave> event bindings, so that those bindings are imitated by baltip. Hence a problem with popup menus: when you right-click those GUI objects,
baltip::tip
and tk_popup
might both fire, which results in a mess.
To avoid this, use ::baltip::sleep
before tk_popup
, for example:
::baltip::sleep 1000 ;# disables tips for 1000 milliseconds tk_popup $popupmenu $X $Y ;# calls a popup menu at $X $Y coordinatesAs for tablelist widget, I would like to cite an advice by Csaba Nemethi :
The support for tablelist is a special case, don't waste your time with it. I have already tested that the built-in tooltip support of Tablelist will work just fine when replacing tklib's tooltip package with baltip (after fixing the reported bugs), and I intend to extend the description of the -tooltipaddcommand option by hints showing how to use this option with baltip instead of BWidget and tklib's tooltip.
The normal tip has no -geometry
option because it's calculated by baltip, to position the tip under its host widget.
By means of -geometry
option you get a balloon message unrelated to any visible widget: it's parented by the toplevel window. The -geometry
option has +X+Y form where X and Y are coordinates of the balloon.
For example:
::baltip::tip .win "It's a balloon at +1+100 (+X+Y) coordinates" \ -geometry +1+100 -font {-weight bold -size 12} \ -alpha 0.8 -fg white -bg black -per10 3000 -pause 1500 -fade 1500The
-pause
and -fade
options make the balloon fade at appearing and disappearing.
The -per10
option means "milliseconds per 10 characters", so it defines the balloon's duration: the more the longer.
The -per10
option is weird a little: while it is active (i.e. while baltip's clock is counting down according to -per10
), other tips are locked. So, -per10 10000000
is a bad idea for balloons, use -eternal 1
instead. If -eternal 1
option is set, -per10 1
is set by force to unlock other tips immediately.
The -geometry
value can include W
and H
wildcards meaning the width and the height of the balloon. This may be useful when you need to show a balloon at a window's edge and should use the balloon's dimensions which are available only after its creation. The X and Y coordinates are calculated by baltip as normal expressions. Of course, they should not include the "+" divider, but this restriction (if any) is easily overcome.
For example:
lassign [split [winfo geometry .win] x+] w h x y set geom "+([expr {$w+$x}]-W-4)+$y" set text "The balloon at the right edge of the window" ::baltip tip .win $text -geometry $geom -pause 2000 -fade 2000To show a balloon under the mouse pointer, e.g. on clicking, timeout, processing etc., the following call is used:
::baltip::showBalloon text ?options?By default,
::baltip::showBalloon
displays the balloon under the mouse pointer. At that it regards -geometry
option and ignores -under, -shiftX, -shiftY
options.
The -command
option allows to display tips in other places, for example in a status bar. At that, the command can include %t
and %w
wildcards, meaning "text" and "widget path". Such tips are well fit for menu items, as seen in test.tcl.
The command of this option must return {}, if no tips should be displayed.
Also, it can return a new tip to display as a usual balloon tip, which fits for "dynamic tips" that are changed at each exposition of a tip.
For example:
proc ::Status {tip} { .labelstatus configure -text $tip return {} ;# no redefining the tip } ::baltip::tip .menu "File actions" -index 0 -command {::Status %t} ::baltip::tip .menu "Help, hints, Q&A, about etc." -index 1 -command {::Status %t}Also, this option can be used if you need to fire some code when the mouse pointer enters or leaves a GUI object.
Note: the baltip is available for a few of GUI objects that have not <Enter> nor <Leave> bindings.
The only line
baltip::tip $w $tip -command $commandmight save you other lines to fire the command at entering/leaving a GUI object. E.g. the command might highlight a GUI object entered, save its ID and unhighlight the object at leaving it.
For example:
proc ::SomeProc {tip} { lassign [split $tip] obj ID column if {[info exists ::OBJsaved]} { puts "$::OBJsaved object ID=[set ::IDsaved] is left... unhighlighted..." unset ::OBJsaved } if {$obj eq {}} return set ::OBJsaved $obj set ::IDsaved $ID puts "Now processing $obj object with ID=$ID column=$column" return {} ;# means the proc executed and no tip needed } ::baltip::tip .listbox {Listbox %i} -command {::SomeProc {%t}} ::baltip::tip .treeview {Treeview %i %c} -command {::SomeProc {%t}}
Below are listed the baltip options that are set with tip
and configure
and got with cget
:
-on
- switches all tips on/off;-per10
- a time of exposition per 10 characters (in millisec.);-fade
- a time of fading (in millisec.);-pause
- a pause before displaying tips (in millisec.);-alpha
- an opacity (from 0.0 to 1.0);-fg
- foreground of tip;-bg
- background of tip;-bd
- borderwidth of tip;-font
- font attributes;-padx
- X padding for text;-pady
- Y padding for text;-padding
- padding for pack;-under
- if >= 0, sets the tip under the widget, else under the pointer;-shiftX
- a horizontal shift relative to the mouse pointer-shiftY
- a vertical shift relative to the mouse pointer-image
- image option;-compound
- compound option;-relief
- relief option;-bell
- if true, rings at displaying;-eternal
- if true, makes a tip "eternal", i.e. visible till clicking.The following options are special:
-global
- if true, applies the settings to all registered tips;-force
- if true, forces the display by 'tip' command;-index
- index of menu item to tip;-tag
- name of text tag to tip;-ctag
- name of canvas tag to tip;-nbktab
- path to ttk::notebook tab to tip;-geometry
- geometry (+X+Y) of the balloon;-reset
- "-reset true" may be useful to set a new tip (callback or text) for listbox and treeview;-command
- a command to be executed, with %t
(tip's text) and %w
(widget's path) wildcards;-maxexp
- maximum number of tip's expositions.-focus
- path to widget to set focus on, after showing a tip
If -global yes
option is used alone, it applies all global options to all registered tips. If -global yes
option is used along with other options, only those options are applied to all registered tips.
Of course, all global options will be applied to all tips to be created after ::baltip configuration
. For example:
::baltip config -global yes ;# applies all global options to all registered and to-be-created tips ::baltip config -global yes -per10 2000 ;# applies `-per10` to all registered and to-be-created tipsThe
-index
option may have numeric (0, 1, 2...) or symbolic form (active, end, none) to indicate a menu entry, e.g. in -command
option. For example:
::baltip repaint .win.popupMenu -index active ::baltip::tip .menu "File actions" -index 0There may be useful to define options in text argument of ::baltip::tip.
For this, provide the text argument as a list of pairs of uppercased options' name / value including -BALTIP option for tip. For example:
::baltip tip .text "-BALTIP {Sort of diary, todos etc.} -MAXEXP 1"As seen in the above examples, baltip can be used as Tcl ensemble, so that the commands may be shortened.
See more examples in test.tcl of baltip.zip.
Also, you can test baltip with test2_pave.tcl of apave package.
The baltip package has been developed with help of these kind people:
########################################################### # Name: baltip.tcl # Author: Alex Plotnikov (aplsimple@gmail.com) # Date: 12/01/2021 # Brief: Handles Tcl/Tk tip widget. # License: MIT. ########################################################### package provide baltip 1.6.2 # ________________________ Variables _________________________ # namespace eval ::baltip { namespace export configure cget tip update hide repaint \ optionlist tippath clear sleep showBalloon showTip namespace ensemble create namespace eval my { variable ttdata; array set ttdata [list] set ttdata(on) yes set ttdata(per10) 1600 set ttdata(fade) 300 set ttdata(pause) 1000 set ttdata(fg) black set ttdata(bg) #FBFB95 set ttdata(bd) 1 set ttdata(padx) 4 set ttdata(pady) 3 set ttdata(padding) 0 set ttdata(alpha) 1.0 set ttdata(bell) no set ttdata(font) [font actual TkTooltipFont] set ttdata(under) -16 set ttdata(image) {} set ttdata(compound) {} set ttdata(relief) {} set ttdata(shiftX) {} set ttdata(shiftY) {} set ttdata(ontop) no set ttdata(balloon) - } } # _________________________ UI ______________________ # proc ::baltip::configure {args} { # Configurates the tip for all widgets or for a widget. # args - options ("name value" pairs) # If *args* begins with a widget path, then # args is "w -opt val ?-opt val?", so the widget tip options are set. # Returns the list of special options' values or a widget's tip options. variable my::ttdata set w [lindex $args 0] if {[winfo exists $w]} { # configure a widget's tip return [tip $w -BALTIPSET {*}[lrange $args 1 end]] } set force no set index -1 lassign {} geometry tag ctag nbktab reset command maxexp focus set global [expr {[dict exists $args -global] && [dict get $args -global]}] foreach {n v} $args { set n1 [string range $n 1 end] switch -glob -- $n { -SPECTIP* - -per10 - -fade - -pause - -fg - -bg - -bd - -alpha - -text - -relief - \ -on - -padx - -pady - -padding - -bell - -under - -font - -image - -compound - \ -shiftX - -shiftY - -ontop - -eternal { set my::ttdata($n1) $v } -force - -geometry - -index - -tag - -global - -ctag - -nbktab - -reset - \ -command - -maxexp - -focus { set $n1 $v } default {return -code error "baltip: invalid option \"$n\""} } if {$global && ($n ne {-global} || [llength $args]==2)} { foreach k [array names my::ttdata -glob on,*] { set w [lindex [split $k ,] 1] set my::ttdata($n1,$w) $v } } } return [list \ $force $geometry $index $tag $ctag $nbktab $reset $command $maxexp $focus] } #_______________________ proc ::baltip::cget {args} { # Gets global option values or a widget's option value. # args - option names (if empty, returns all options) # If *args* begins with a widget path, then args is "w -option", # so the widget tip option's value is returned (e.g. for -text option). # Returns a list of "name value" pairs or an option value of a widget's tip. variable my::ttdata if {![llength $args]} { lappend args {*}[optionlist] } set w [lindex $args 0] if {[winfo exists $w]} { set dic [tip $w -BALTIPGET] if {[set opt [lindex $args 1]] ne {}} { if {[dict exists $dic $opt]} { return [dict get $dic $opt] } return {} } return $dic } set res [list] foreach n $args { set n [string range $n 1 end] if {[info exists my::ttdata($n)]} { lappend res -$n $my::ttdata($n) } } return $res } #_______________________ proc ::baltip::optionlist {} { # All options of baltip. return [list -on -per10 -fade -pause -fg -bg -bd -padx -pady -padding -font \ -alpha -text -index -tag -bell -under -image -compound -relief -ctag \ -nbktab -reset -command -maxexp -focus -shiftX -shiftY -ontop -eternal] } #_______________________ proc ::baltip::tippath {w} { # Gets a tip window's path. # w - widget's path return [string trimright $w .].w__BALTIP } #_______________________ proc ::baltip::tip {w {text "-BALTIPGET"} args} { # Creates a tip for a widget. # w - the parent widget's path # text - the tip text # args - options ("name value" pairs) # If *text* is equal to "-BALTIPGET", returns options of widget's tip # If *text* is equal to "-BALTIPSET", sets options of widget's tip variable my::ttdata array unset my::ttdata winGEO* if {[winfo exists $w] || $w eq {}} { if {$text in {-BALTIPGET -BALTIPSET}} { # "-BALTIPGET" is the same as "-BALTIPSET", just supposed not to include args if {![info exists my::ttdata(optvals,$w)]} { if {$text eq {-BALTIPGET}} {return {}} set my::ttdata(optvals,$w) [dict create] } set my::ttdata(optvals,$w) [dict replace $my::ttdata(optvals,$w) {*}$args] if {$text eq {-BALTIPGET}} { return $my::ttdata(optvals,$w) } if {[catch {set text [dict get $my::ttdata(optvals,$w) -text]}]} { return {} } } set arrsaved [array get my::ttdata] set optvals [::baltip::my::CGet {*}$args] # block of related lines for special options set specopt {forced geo index ttag ctag nbktab reset command maxexp focus} lassign $optvals {*}$specopt set optArgs [lrange $optvals [llength $specopt] end] ;# get rid of spec.options if {[catch {set optvals $my::ttdata(optvals,$w)}]} { set optvals $optArgs } # end of block set my::ttdata(global,$w) no # no redefining a command once set if {[info exists ttdata(command,$w)] && [string is false $reset]} { set command $my::ttdata(command,$w) } else { set my::ttdata(command,$w) $command } if {$command ne {}} {::baltip::update $w $text} if {![info exists my::ttdata(maxexp,$w)]} { set my::ttdata(maxexp,$w) $maxexp } if {[winfo exists $focus]} { set my::ttdata(focus,$w) $focus } set text [my::OptionsFromText $w $text] ;# may reset -command and -maxexp set ontags [string length $nbktab$ctag$ttag] set onopt [expr {[string length $text] && $my::ttdata(on) || $ontags}] set optArgs [dict replace $optArgs -text $text] set optvals [dict replace $optvals -text $text] set et 0 catch {set et [dict get $args -eternal]} if {[set my::ttdata(eternal,$w) $et]} {lappend optvals -per10 1} set my::ttdata(optvals,$w) $optvals set my::ttdata(on,$w) $onopt if {$text ne {} || $ontags} { if {$forced || $geo ne {}} {::baltip::my::Show $w $text yes $geo $optvals} if {$geo ne {}} { # balloon popup message array set my::ttdata $arrsaved set my::ttdata(balloon) $w } else { set widgetclass [winfo class $w] set tags [bindtags $w] if {[lsearch -exact $tags "Tooltip$w"] == -1} { bindtags $w [linsert $tags end "Tooltip$w"] } bind Tooltip$w <Any-Leave> "::baltip::hide $w" bind Tooltip$w <Any-KeyPress> "::baltip::hide $w" bind Tooltip$w <Any-Button> "::baltip::hide $w" if {$index>-1} { # tip for menu items set my::ttdata(LASTMITEM) {} set wt [my::Clonename $w] foreach w2 [list $w $wt] { set my::ttdata(on,$w2) $onopt set my::ttdata($w2,$index) $optArgs set my::ttdata(command,$w2) $command set my::ttdata(global,$w2) no } my::BindToEvent Menu <<MenuSelect>> ::baltip::my::MenuTip %W } elseif {$ttag ne {}} { # tip for text tags set my::ttdata($w,$ttag) $text my::BindTextagToEvent $w $ttag <Enter> ::baltip::my::TagTip $w $ttag $optArgs foreach event {Leave KeyPress Button} { my::BindTextagToEvent $w $ttag <$event> ::baltip::my::TagTip $w } } elseif {$ctag ne {}} { # tip for canvas tags set my::ttdata($w,$ctag) $text my::BindCantagToEvent $w $ctag <Enter> ::baltip::my::TagTip $w $ctag $optArgs my::BindCantagToEvent $w $ctag <Leave> ::baltip::my::TagTip $w } elseif {$nbktab ne {}} { # tip for notebook tabs configure -SPECTIP$nbktab $text bind Tooltip$w <Button-1> "::baltip::my::NbkInfo $w %x %y -" bind Tooltip$w <Motion> "::baltip::my::PrepareNbkTip $w %x %y" } elseif {$widgetclass eq {Listbox}} { # tip for listbox items if {[cget -SPECTIP$w] eq {} || [string is true -strict $reset]} { configure -SPECTIP$w $text } bind Tooltip$w <Any-Leave> \ "::baltip hide $w; ::baltip configure -SPECTIPid$w {}" bind Tooltip$w <Motion> "::baltip::my::PrepareLbxTip $w %x %y" } elseif {$widgetclass eq {Treeview}} { # tip for treeview items if {[cget -SPECTIP$w] eq {} || [string is true -strict $reset]} { configure -SPECTIP$w $text } bind Tooltip$w <Any-Leave> \ "::baltip hide $w; ::baltip configure -SPECTIPid$w {}" bind Tooltip$w <Motion> "::baltip::my::PrepareTreTip $w %x %y" } else { bind Tooltip$w <Enter> [list ::baltip::my::Show %W $text no $geo $optvals] } } } } return {} } #_______________________ proc ::baltip::update {w text args} { # Updates tip's text and settings. # w - widget's path # text - tip's text # args - tip's settings variable my::ttdata set my::ttdata(text,$w) $text foreach {k v} $args {set my::ttdata([string range $k 1 end],$w) $v} } #_______________________ proc ::baltip::repaint {w args} { # Repaints a tip immediately. # w - widget's path # args - options (incl. -index/-tag) variable my::ttdata if {[winfo exists $w] && [info exists my::ttdata(optvals,$w)] && \ [dict exists $my::ttdata(optvals,$w) -text]} { set optvals $my::ttdata(optvals,$w) lappend optvals {*}$args catch {after cancel $my::ttdata(after)} set win [tippath $w] ;# the tip's window if {[info exists my::ttdata(winGEO,$win)]} { set geo $my::ttdata(winGEO,$win) } else { set geo {} } set my::ttdata(after) [after idle [list ::baltip::my::Show $w \ [dict get $my::ttdata(optvals,$w) -text] yes $geo $optvals]] } } #_______________________ proc ::baltip::hide {{w ""} {doit no}} { # Destroys the tip's window. # w - widget's path # doit - yes, if do hide by force # Returns 1, if the window was really hidden. variable my::ttdata my::Command $w {} set res 1 if {(![my::Eternal $w] && $my::ttdata(balloon) ne $w) || $doit} { set res [expr {![catch {destroy [tippath $w]}]}] if {$w eq $my::ttdata(balloon)} {set my::ttdata(balloon) -} } return $res } #_______________________ proc ::baltip::clear {w args} { # Removes tip bindings for a widget. # w - widget's path variable my::ttdata catch {unset my::ttdata(optvals,$w)} catch {hide $w} foreach ev {Any-Leave Any-KeyPress Any-Button Motion Any-Enter Leave Enter} { catch {bind Tooltip$w <$ev> {}} } } #_______________________ proc ::baltip::sleep {msec} { # Disables tips for a while. # msec - time to sleep, in msec # This is useful esp. before calling a popup menu on listbox/treeview. configure -on no after $msec "::baltip::configure -on yes" } #_______________________ proc ::baltip::showBalloon {tip args} { # Shows a balloon under the pointer or according to -geometry option. # tip - text of tip # args - miscellaneous options of baltip # Can be used to show tips on clicking, timeout, processing etc. # If there is -geometry in args, shows the balloon # with this geometry and a minimal pause. variable my::ttdata set w . if {[set isgeo [dict exists $args -geometry]]} { lappend args -pause 10 } else { lassign [winfo pointerxy $w] x y lappend args -geometry \ +[expr {$x-int($my::ttdata(under)/2)}]+[expr {$y-$my::ttdata(under)}] } tip $w $tip -pause 100 -fade 100 {*}$args if {$isgeo} { after 20 ::update } } #_______________________ proc ::baltip::showTip {w tip args} { # Shows a tip under the pointer, for a specific widget. # tip - text of tip # args - miscellaneous options of baltip # Can be used to show tips on clicking the widget # that has no "normal" tips on hovering it. my::BindToEvent $w <Leave> ::baltip hide . showBalloon $tip {*}$args } # _____________________ Internals ____________________ # proc ::baltip::my::CGet {args} { # Gets options' values, using local (args) and global (ttdata) settings. # args - local settings ("name value" pairs) # Returns the full list of settings ("name value" pairs, "name" without "-") \ in which special options go first. # See also: cget, configure variable ttdata set saved [array get ttdata] set res [::baltip::configure {*}$args] lappend res {*}[::baltip::cget] array set ttdata $saved return $res } #_______________________ proc ::baltip::my::WidCoord {w} { # Gets widget's coordinate data. # w - path to the widget # Returns a list of: # x - X coordinate # y - Y coordinate # inside - flag "mouse pointer is inside the widget" set x [expr {[winfo pointerx $w]-[winfo rootx $w]}] set y [expr {[winfo pointery $w]-[winfo rooty $w]}] lassign [split [winfo geometry $w] x+] width height set inside [expr {$x>-1 && $x<$width && $y>-1 && $y<$height}] return [list $x $y $inside] } #_______________________ proc ::baltip::my::Clonename {mnu} { # Gets a clone name of a menu. # mnu - the menu's path # This procedure is borrowed from BWidget's utils.tcl. set path [set menupath {}] set found 0 foreach widget [lrange [split $mnu .] 1 end] { if {$found || [winfo class "$path.$widget"] eq {Menu}} { set found 1 append menupath # $widget append path . $menupath } else { append menupath # $widget append path . $widget } } return $path } #_______________________ proc ::baltip::my::OptionsFromText {w txt} { # Extracts options from "text" argument of baltip::tip. # w - widget's path # txt - "-text" option's value # Options can be set in the "text" argument as uppercased-name / value pairs: # "-BALTIP {True tip's text} -MAXEXP 1 -COMMAND {::mycom %i %c}" # In this case, *txt* must be a correct list of name/value sequences. # Returns an original *txt* or a value of -BALTIP option from *txt*. variable ttdata if {[string first {-BALTIP } $txt] >-1 && \ !([catch {set lst [list {*}$txt]}] || [expr {[llength $lst] % 2 }])} { set ol [::baltip::optionlist] lappend ol -baltip foreach o $ol {lappend OL [string toupper $o]} foreach {o v} $lst { if {[set i [lsearch -exact $OL $o]]>-1} { set n1 [string range [lindex $ol $i] 1 end] set ttdata($n1,$w) $v if {$o eq {-BALTIP}} {set txt $v} } } } else { if {[winfo exists ttdata(optvals,$w)]} { catch { set txt [dict get $ttdata(optvals,$w) -text] } } } return $txt } #_______________________ proc ::baltip::my::Eternal {w} { # Checks if the tip is shown till clicking. # w - tip/widget's path variable ttdata set res no if {[catch {set res $ttdata(eternal,$w)}]} { catch {set res $ttdata(eternal,[winfo parent $w])} } return $res } ## ________________________ Binds _________________________ ## proc ::baltip::my::BindToEvent {w event args} { # Binds an event on a widget to a command. # w - the widget's path # event - the event # args - the command # The command can be ended with " ; break". if {[catch {set bound [bind $w $event]}]} {set bound {}} if {[string first $args $bound]<0} { catch { if {[lrange $args end-1 end] eq "{;} break"} { set com [lrange $args 0 end-2] bind $w $event "$com ; break" } else { bind $w $event [list + {*}$args] } } } } #_______________________ proc ::baltip::my::BindTextagToEvent {w tag event args} { # Binds an event on a text tag to a command. # w - the widget's path # tag - the tag # event - the event # args - the command # The command can be ended with " ; break". if {[catch {set bound [$w tag bind $tag]}]} {set bound {}} if {[string first $args $bound]<0} { catch { if {[lrange $args end-1 end] eq "{;} break"} { set com [lrange $args 0 end-2] $w tag bind $tag $event "$com ; break" } else { $w tag bind $tag $event [list + {*}$args] } } } } #_______________________ proc ::baltip::my::BindCantagToEvent {w tag event args} { # Binds an event on a canvas tag to a command. # w - the widget's path # tag - the tag # event - the event # args - the command # The command can be ended with " ; break". if {[catch {set bound [$w bind $tag $event]}]} {set bound {}} if {[string first $args $bound]<0} { catch { if {[lrange $args end-1 end] eq "{;} break"} { set com [lrange $args 0 end-2] $w bind $tag $event "$com ; break" } else { $w bind $tag $event [list + {*}$args] } } } } ## ________________________ Shows _________________________ ## proc ::baltip::my::Command {w text} { # Executes a command set for a window. # w - the widget's path # text - the tip text # The command allows wildcards: # %w - window's path # %t - text of the tip # Returns: list of "yes/no" and a result of the command. # The result of the command can be a new tip if "yes" and the result ne {}. variable ttdata if {![info exists ttdata(command,$w)] || $ttdata(command,$w) eq {}} {return no} set com [string map [list %w $w %t "{$text}"] $ttdata(command,$w)] if {[catch {set res [eval $com]} e]} {return no} if {$text ne {}} { set ttdata(text,$w) $res } return [list yes $res] } #_______________________ proc ::baltip::my::ShowWindow {win} { # Shows a window of tip. # win - the tip's window variable ttdata if {![winfo exists $win] || ![info exists ttdata(winGEO,$win)]} return set geo $ttdata(winGEO,$win) set under $ttdata(winUNDER,$win) set shiftX $ttdata(winSHIFTX,$win) set shiftY $ttdata(winSHIFTY,$win) set w [winfo parent $win] set px [winfo pointerx .] set py [winfo pointery .] set width [winfo reqwidth $win.label] set height [winfo reqheight $win.label] set ady 0 if {[catch {set wheight [winfo height $w]}]} { set wheight 0 } else { for {set i 0} {$i<$wheight} {incr i} { ;# find the widget's bottom incr py incr ady if {![string match $w* [winfo containing $px $py]]} break } } if {$geo eq {}} { if {$shiftX ne {}} { set x [expr {$px + $shiftX}] } else { set x [expr {max(1,$px - round($width / 2.0))}] } set y [expr {$under>=0 ? ($py + $under) : ($py - $under - $ady)}] if {$shiftY ne {}} {incr y $shiftY} } else { lassign [split $geo +] -> x y set x [expr [string map "W $width" $x]] ;# W to shift horizontally set y [expr [string map "H $height" $y]] ;# H to shift vertically } # check for edges of screen incl. decors set scrw [winfo vrootwidth .] set scrh [winfo vrootheight .] if {($x + $width) > $scrw} {set x [expr {$scrw - $width - 1}]} if {($y + $height) > $scrh} {set y [expr {$py - $height - 16}]} set x [expr {max(0,$x)}] set y [expr {max(0,$y)}] wm geometry $win [join "$width x $height + $x + $y" {}] catch {wm deiconify $win ; raise $win} } #_______________________ proc ::baltip::my::Show {args} { # Calls DoShow catching errors. catch {DoShow {*}$args} } #_______________________ proc ::baltip::my::DoShow {w text force geo optvals} { # Creates and shows the tip's window. # w - the widget's path # text - the tip text # force - if true, re-displays the existing tip # geo - being +X+Y, sets the tip coordinates # optvals - settings ("option value" pairs) # See also: Fade, ShowWindow, ::baltip::update variable ttdata if {![winfo exists $w]} return set win [::baltip::tippath $w] # keep the label's colors untouched (for apave package) catch {::apave::obj untouchWidgets $win.label} set px [winfo pointerx .] set py [winfo pointery .] array set data $optvals if {[info exists ttdata(optvals,$w)]} { catch {array set data [list {*}$ttdata(optvals,$w) {*}$optvals]} } if {$geo ne {}} { # balloons not related to widgets } elseif {$ttdata(global,$w)} { ;# flag 'use global settings' array set data [::baltip::cget] } else { foreach k [array names ttdata -glob *,$w] { set n1 [lindex [split $k ,] 0] ;# settings set by 'update' if {$n1 eq {text}} { if {$ttdata($k) ne {}} { set text $ttdata($k) ;# tip's text } } else { set data(-$n1) $ttdata($k) ;# tip's options } } } if {[catch {set widgetclass [winfo class $w]}]} { set widgetclass {} } if {!$force && $geo eq {}} { if {![info exists ttdata(on,$w)] || !$ttdata(on,$w)} return if {$widgetclass ne {Menu} && \ ([winfo exists $win] || ![string match $w* [winfo containing $px $py]])} { return } } if {$geo eq {}} {::baltip::hide $w} set icount [string length [string trim $text]] if {!$icount || (!$ttdata(on) && !$data(-on))} return lassign [Command $w $text] ans res if {$ans} { if {$res eq {}} { # the command displayed the tip somewhere return } # the command redefined the tip's text set text $res } if {[info exists ttdata(maxexp,$w)] && \ [string is integer -strict $ttdata(maxexp,$w)]} { if {$ttdata(maxexp,$w)<=0} return } lappend ttdata(REGISTERED) $w foreach wold [lrange $ttdata(REGISTERED) 0 end-1] {::baltip::hide $wold} if {$data(-fg) eq {}} {set data(-fg) black} if {$data(-bg) eq {}} {set data(-bg) #FBFB95} catch {destroy $win} toplevel $win -bg $data(-bg) -class Tooltip$w catch {wm withdraw $win} wm overrideredirect $win 1 if {[info exists data(-ontop)] && $data(-ontop)} { wm attributes $win -topmost 1 } if {$data(-relief) eq {}} {set data(-relief) solid} if {[set imgoptions $data(-image)] ne {}} { set imgoptions "-image $imgoptions" } if {[set cmpdoptions $data(-compound)] ne {}} { set cmpdoptions "-compound $cmpdoptions" } if {$imgoptions ne {} && $cmpdoptions eq {}} { set cmpdoptions {-compound left} } pack [label $win.label -text $text -justify left -relief $data(-relief) \ -bd $data(-bd) -bg $data(-bg) -fg $data(-fg) -font $data(-font) \ {*}$imgoptions {*}$cmpdoptions -padx $data(-padx) -pady $data(-pady)] \ -padx $data(-padding) -pady $data(-padding) if {[info exists ttdata(focus,$w)]} { set foc $ttdata(focus,$w) after idle "catch {focus -force \[winfo toplevel $foc\]}; catch {focus $foc}" } # defeat rare artifact by passing mouse over a tip to destroy it bindtags $win "Tooltip$win" if {$geo eq {}} { # balloons are hidden on click or time-out bind $win <Any-Enter> "::baltip::hide $w" bind Tooltip$win <Any-Enter> "::baltip::hide $w" } bind $win <Any-Button> "::baltip::hide $w 1" bind Tooltip$win <Any-Button> "::baltip::hide $w 1" set aint 20 set fint [expr {int($data(-fade)/$aint)}] set icount [expr {int($data(-per10)/$aint*$icount/10.0)}] set icount [expr {$data(-per10) ? max(1000/$aint+1,$icount) : 0}] ;# 1 sec. minimum set ttdata(winGEO,$win) $geo set ttdata(winUNDER,$win) $data(-under) set ttdata(winSHIFTX,$win) $data(-shiftX) set ttdata(winSHIFTY,$win) $data(-shiftY) if {$icount} { if {$geo eq {}} { catch {wm attributes $win -alpha $data(-alpha)} } else { Fade $win $aint [expr {round(1.0*$data(-pause)/$aint)}] \ 0 Un $data(-alpha) 1 $geo {} $w } if {$force} { Fade $win $aint $fint $icount {} $data(-alpha) 1 $geo {} $w } elseif {$widgetclass ne {TNotebook}} { catch {after cancel $ttdata(after)} set ttdata(after) [after $data(-pause) [list \ ::baltip::my::Fade $win $aint $fint $icount {} $data(-alpha) 1 $geo {} $w]] } } else { # just showing, no fading catch {after cancel $ttdata(after)} set ttdata(after) [after $data(-pause) \ "::baltip::my::ShowWindow $win; catch {wm attributes $win -alpha $data(-alpha)}"] } if {$data(-bell)} [list after [expr {$data(-pause)/4}] bell] array unset data } ## ________________________ Fade _________________________ ## proc ::baltip::my::Fade {win aint fint icount Un alpha show geo {geos ""} {w {}}} { # Fades/unfades the tip's window. # win - the tip's window # aint - interval for 'after' # fint - interval for fading # icount - counter of intervals # Un - if equal to "Un", unfades the tip # alpha - value of -alpha option # show - flag "show the window" # geo - coordinates (+X+Y) of balloon # geos - saved coordinates (+X+Y) of shown tip # w - a host window # See also: FadeNext, UnFadeNext variable ttdata if {[winfo exists $win]} { if {$show && [info exists ttdata(maxexp,$w)] && \ [string is integer -strict $ttdata(maxexp,$w)]} { incr ttdata(maxexp,$w) -1 } update catch {after cancel $ttdata(after)} set ttdata(after) [after idle [list after $aint \ [list ::baltip::my::${Un}FadeNext $win $aint $fint $icount $alpha $show $geo $geos]]] } } #_______________________ proc ::baltip::my::FadeNext {w aint fint icount alpha show geo {geos ""}} { # A step to fade the tip's window. # w - the tip's window # aint - interval for 'after' # fint - interval for fading # icount - counter of intervals # alpha - value of -alpha option # show - flag "show the window" # geo - coordinates (+X+Y) of balloon # geos - saved coordinates (+X+Y) of shown tip # See also: Fade variable ttdata incr icount -1 if {$show} {ShowWindow $w} set show 0 if {![winfo exists $w]} return lassign [split [wm geometry $w] +] -> X Y if {$geos ne {} && $geos ne "+$X+$Y"} return if {$fint<=0} {set fint 10} if {[catch {set al [expr {min($alpha,($fint+$icount*1.5)/$fint)}]}]} { set al 0 } if {$icount<0} { if {[Eternal $w]} return if {$al>0} { if {[catch {wm attributes $w -alpha $al}]} {set al 0} } if {$al<=0.001 || ![winfo exists $w]} { ::baltip::hide catch {destroy $w} return } } elseif {$al>0 && $geo eq {}} { if {![Eternal $ttdata(balloon)] && $ttdata(balloon) ne {-}} { ::baltip::hide $ttdata(balloon) yes ;# non-eternal balloon be destroyed } catch {wm attributes $w -alpha $al} } Fade $w $aint $fint $icount {} $alpha $show $geo +$X+$Y } #_______________________ proc ::baltip::my::UnFadeNext {w aint fint icount alpha show geo {geos ""}} { # A step to unfade the balloon's window. # w - the tip's window # aint - interval for 'after' # fint - interval for fading # icount - counter of intervals # alpha - value of -alpha option # show - not used (here just for compliance with Fade) # geo - not used (here just for compliance with Fade) # geos - not used (here just for compliance with Fade) # See also: Fade incr icount set al [expr {min($alpha,$icount*1.5/$fint)}] if {$al<$alpha && [catch {wm attributes $w -alpha $al}]} {set al 1} if {$show} { ShowWindow $w set show 0 } if {[winfo exists $w] && $al<$alpha} { Fade $w $aint $fint $icount Un $alpha 0 $geo } } ## ________________________ Specific widgets _________________________ ## ### ________________________ Tags _________________________ ### proc ::baltip::my::TagTip {w {tag ""} {optvals ""}} { # Shows a text tag's tip. # w - the text's path # tag - the tag's name # optvals - settings of tip variable ttdata ::baltip::hide $w if {$tag eq {}} return ::baltip::my::Show $w $ttdata($w,$tag) no {} $optvals } ### ________________________ Menu _________________________ ### proc ::baltip::my::MenuTip {wt} { # Shows a menu's tip. # wt - the menu's path (incl. cloned menu) variable ttdata if {[string match .tearoff* $wt]} { # not implemented for tear-offed menus return } ::baltip::hide $wt set index [$wt index active] set mit "$wt/$index" if {$index eq {none}} return if {[info exists ttdata($wt,$index)] && ([::baltip::hide $wt] || \ ![info exists ttdata(LASTMITEM)] || $ttdata(LASTMITEM) ne $mit)} { set optvals $ttdata($wt,$index) set text [dict get $optvals -text] ::baltip::my::Show $wt $text no {} $optvals } set ttdata(LASTMITEM) $mit } ### ________________________ Notebook _________________________ ### proc ::baltip::my::NbkInfo {w x y {tab {}}} { # Gets/sets a notebook tab's data. # w - the notebook's path # x - X coordinate of pointer # y - Y coordinate of pointer # tab - a current tab # When getting, returns a list of a current tab and a saved tab. set optid -SPECTIP$w if {$tab eq {}} { set tab [$w identify tab $x $y] set tab2 [lindex [::baltip cget $optid] 1] return [list $tab $tab2] } ::baltip configure $optid $tab } #_______________________ proc ::baltip::my::ShowNbkTip {w tip} { # Shows a tip for a notebook tab. # w - the notebook's path # tip - text of tip catch { set x [expr {[winfo pointerx $w]-[winfo rootx $w]}] set y [expr {[winfo pointery $w]-[winfo rooty $w]}] lassign [NbkInfo $w $x $y] tab tab2 set wt [lindex [$w tabs] $tab] if {$tab2 ne {-} && [lsearch -exact [$w tabs] $wt]>-1} { ::baltip tip $w $tip -force yes } else { ::baltip hide $w } } } #_______________________ proc ::baltip::my::PrepareNbkTip {w x y} { # Prepares a tip for a notebook tab. # w - the notebook's path # x - X coordinate of pointer # y - Y coordinate of pointer # The baltip isn't directly usable with notebook tabs # because they have not Enter/Leave event bindings. # This proc tries to imitate those events, with binding to <Motion> event. if {![string is integer -strict $x]} return catch { lassign [::baltip cget -pause] -> pause lassign [NbkInfo $w $x $y] tab tab2 set nbktab [lindex [$w tabs] $tab] if {$tab ne {} && $tab2 ni "$tab -"} { ::baltip hide $w lassign [::baltip cget -SPECTIP$nbktab] -> tip lassign [Command $w $tip] ans res if {$ans} { if {$res ne {}} { # the command should be displayed here (not somewhere else) set $ans no } # the command redefined the tip's text set tip $res } if {!$ans} { set optafter -SPECTIPafter$w catch { after cancel [lindex [::baltip cget $optafter] 1] } set aftid [after $pause "::baltip::my::ShowNbkTip $w {$tip}"] ::baltip configure $optafter $aftid } } else { NbkInfo $w $x $y -1 } NbkInfo $w $x $y $tab } } ### ________________________ Listbox _________________________ ### proc ::baltip::my::LbxCoord {w} { # Gets listbox's coordinate data. # w - path to the listbox # Returns a list of: # x - X coordinate # y - Y coordinate # idx - index of listbox's item # inside - flag "mouse pointer is inside the listbox" lassign [WidCoord $w] x y inside set idx [$w index @$x,$y] return [list $x $y $idx $inside] } #_______________________ proc ::baltip::my::LbxTip {w idx whole} { # Gets a text of a listbox' tip. # w - the listbox's path # idx - index of listbox's item # whole - flag "tip for a whole listbox, not per item" lassign [::baltip cget -SPECTIP$w] - com if {$whole} { set tip [string map "%%i %i" $com] } else { set com [string map [list %i $idx] $com] if {[catch {set tip [eval $com]}]} {set tip $com} } return $tip } #_______________________ proc ::baltip::my::ShowLbxTip {w optid idx whole} { # Shows a tip for a listbox. # w - the listbox's path # optid - option name for saving *idx* # idx - index of listbox's item # whole - flag "tip for a whole listbox, not per item" catch { lassign [LbxCoord $w] x y idx inside if {$inside} { set tip [LbxTip $w $idx $whole] ::baltip configure $optid $idx ::baltip tip $w $tip -force yes } else { ::baltip hide $w ::baltip configure $optid {} } } } #_______________________ proc ::baltip::my::PrepareLbxTip {w x y} { # Prepares a tip for a listbox. # w - the listbox's path # x - X coordinate of pointer # y - Y coordinate of pointer # Imitates Enter/Leave events per items, with binding to <Motion> event. # If "-text" of tip doesn't contain %i, the tip is for a whole listbox. # If "-text" of tip contains %i, the tip is a callback with %i as item index. if {![string is integer -strict $x]} return catch { set idx [$w index @$x,$y] lassign [::baltip cget -pause] -> pause set optid -SPECTIPid$w lassign [::baltip cget $optid] -> idx2 lassign [LbxCoord $w] x y idx inside if {$inside && $idx!=$idx2} { lassign [::baltip cget -SPECTIP$w] - com set com [string map "%%i \u0001" $com] set whole [expr {[string first %i $com]==-1}] set com [string map "\u0001 %i" $com] set text [LbxTip $w $idx $whole] if {$whole && $idx2 ne {}} { Command $w $text return ;# tip for a whole listbox at entering } ::baltip hide $w lassign [Command $w $text] ans res if {$ans} { if {$res ne {}} { # the command should be displayed here (not somewhere else) set $ans no } # the command redefined the tip's text set text $res } if {!$ans} { set optafter -SPECTIPafter$w catch {after cancel [lindex [::baltip cget $optafter] 1]} set aftid [after $pause "::baltip::my::ShowLbxTip $w $optid $idx $whole"] ::baltip configure $optafter $aftid } ::baltip configure $optid $idx } } } ### ________________________ Treeview _________________________ ### proc ::baltip::my::TreCoord {w whole} { # Gets treeview's coordinate data. # w - path to the treeview # whole - flag "tip for a whole treeview, not per item" # Returns a list of: # x - X coordinate # y - Y coordinate # id - ID of item # c - column of item # inside - flag "mouse pointer is inside the treeview" lassign [WidCoord $w] x y inside set id [$w identify item $x $y] set c [$w identify column $x $y] if {!$whole && [$w identify region $x $y] eq {heading}} { set inside no } return [list $x $y $id $c $inside] } #_______________________ proc ::baltip::my::TreTip {w id c whole} { # Gets a text of a treeview' tip. # w - the treeview's path # id - ID of item # c - column of item # whole - flag "tip for a whole treeview, not per item" lassign [::baltip cget -SPECTIP$w] - com if {$whole} { set tip [string map "%%i %i %%c %c" $com] } else { set tip {} set com [string map [list %i $id %c $c] $com] if {$id ne {} && [catch {set tip [eval $com]}]} {set tip $com} } return $tip } #_______________________ proc ::baltip::my::ShowTreTip {w optid id whole} { # Shows a tip for a treeview. # w - the treeview's path # optid - option name for saving *id* # id - ID of item # whole - flag "tip for a whole treeview, not per item" catch { lassign [TreCoord $w $whole] x y id c inside if {$inside} { set tip [TreTip $w $id $c $whole] ::baltip configure $optid [list $id $c] ::baltip tip $w $tip -force yes } else { ::baltip hide $w ::baltip configure $optid {} } } } #_______________________ proc ::baltip::my::PrepareTreTip {w x y} { # Prepares a tip for a treeview. # w - the treeview's path # x - X coordinate of pointer # y - Y coordinate of pointer # Imitates Enter/Leave events per items, with binding to <Motion> event. # If "-text" of tip doesn't contain %i, the tip is for a whole treeview. # If "-text" of tip contains %i, the tip is a callback with %i as item index. if {![string is integer -strict $x]} return catch { set id [$w identify item $x $y] lassign [::baltip cget -pause] -> pause set optid -SPECTIPid$w lassign [lindex [::baltip cget $optid] 1] id2 c2 lassign [::baltip cget -SPECTIP$w] - com set com [string map "%%i \u0001 %%c \u0002" $com] set isid [expr {[string first %i $com]>-1}] set isc [expr {[string first %c $com]>-1}] set whole [expr {!$isid && !$isc}] set com [string map "\u0001 %i \u0002 %c" $com] lassign [TreCoord $w $whole] x y id c inside if {$whole || ($inside && $id ne {} && $c ne {} && (($isid && $id ne $id2) || ($isc && $c ne $c2)))} { set text [TreTip $w $id $c $whole] if {$whole && $id2 ne {}} { Command $w $text return ;# tip for a whole treeview at entering } lassign [Command $w $text] ans res if {$ans} { if {$res ne {}} { # the command should be displayed here (not somewhere else) set $ans no } # the command redefined the tip's text set text $res } if {!$ans} { ::baltip hide $w set optafter -SPECTIPafter$w catch {after cancel [lindex [::baltip cget $optafter] 1]} set aftid [after $pause "::baltip::my::ShowTreTip $w $optid {$id} $whole"] ::baltip configure $optafter $aftid } ::baltip configure $optid [list $id $c] } elseif {$id eq {}} { ::baltip hide $w ::baltip configure $optid {} } } } # ________________________________ EOF __________________________________ #