The current tooltip implementation has some quirks: * tiny font: when normal font is readable, tiny font is less readable :/ * when entering an element with a tooltip the tooltip pops up even when the mouse has left the element in the meantime * tooltip stays open 15 seconds - assuming that everybody can read every tooltip in less than 15s; such assumptions are almost ever wrong
The patch is basically a reimplementation of tooltip.tcl: * use normal font * immediatly open/close a tooltip after entering/leaving an element * let the tooltip stay open until the mouse leaves the element * no useless method layer between events and the tooltip-display method; and no obscure locking mechanisms The change integrates the snippet by Chris Edwards at http://wiki.tcl.tk/1954. --- tcl/utils/tooltip.tcl | 145 ++++++++++++++++++++------------------------------ 1 file changed, 57 insertions(+), 88 deletions(-) diff --git a/tcl/utils/tooltip.tcl b/tcl/utils/tooltip.tcl index b5d4b0f..14d08e1 100644 --- a/tcl/utils/tooltip.tcl +++ b/tcl/utils/tooltip.tcl @@ -6,18 +6,14 @@ namespace eval ::utils::tooltip {} set ::utils::tooltip::showToolTips 1 -set ::utils::tooltip::time 0 -set ::utils::tooltip::enteredWidget {} -set ::utils::tooltip::tooltipDelay 400 +set ::utils::tooltip::tooltipDelay 500 set ::utils::tooltip::tooltipWidth 30 -array set ::utils::tooltip::message {} - # Construct tooltip window: # toplevel .tooltip label .tooltip.text -relief solid -borderwidth 1 -justify left \ - -background #f5f5f5 -padx 3 -pady 1 -font font_Tiny + -background #f5f5f5 -padx 3 -pady 1 pack .tooltip.text -side left wm overrideredirect .tooltip 1 if { $macOS } { @@ -32,27 +28,18 @@ wm withdraw .tooltip # Set the tooltip message for <button> to be <msg> # proc ::utils::tooltip::Set { button msg } { + variable showToolTips variable message + variable tooltipDelay + if {! $showToolTips} { return } set msg [string trim $msg] if {$msg == ""} { return } regsub {\\n} $msg "\n" msg set msg [::utils::tooltip::trimWidth $msg] - set message($button) $msg - bind $button <Any-Enter> +[list ::utils::tooltip::Enter $button] - bind $button <Any-Leave> +[list ::utils::tooltip::Leave $button] -} - -# ::utils::tooltip::SetTag -# -# remove a tooltip message for a given button -# -proc ::utils::tooltip::UnSet { button } { - variable message - if { [info exists ::utils::tooltip::message($button)] } { - unset message($button) - bind $button <Any-Enter> "" - bind $button <Any-Leave> "" - } + bind $button <Any-Enter> [list after $tooltipDelay [list ::utils::tooltip::Show %W $msg]] + bind $button <Any-Leave> [list after $tooltipDelay [list destroy %W.tooltip]] + bind $button <Any-KeyPress> [list after $tooltipDelay [list destroy %W.tooltip]] + bind $button <Any-Button> [list after $tooltipDelay [list destroy %W.tooltip]] } # ::utils::tooltip::SetTag @@ -60,85 +47,68 @@ proc ::utils::tooltip::UnSet { button } { # Set the tooltip message for a text with tag <tag> to be <msg> # proc ::utils::tooltip::SetTag { text_widget msg tag } { + variable showToolTips variable message + if {! $showToolTips} { return } set msg [string trim $msg] if {$msg == ""} { return } regsub {\\n} $msg "\n" msg set msg [::utils::tooltip::trimWidth $msg] - set message(${tag}_$text_widget) $msg - $text_widget tag bind $tag <Any-Enter> +[list ::utils::tooltip::Enter ${tag}_$text_widget] - $text_widget tag bind $tag <Any-Leave> +[list ::utils::tooltip::Leave ${tag}_$text_widget] + $text_widget tag bind $tag <Any-Enter> [list after $tooltipDelay [list ::utils::tooltip::Show ${tag}_$text_widget $msg] + $text_widget tag bind $tag <Any-Leave> [list after $tooltipDelay [list destroy ${tag}_$text_widget.tooltip]] + $text_widget tag bind $tag <Any-KeyPress> [list after $tooltipDelay [list destroy ${tag}_$text_widget.tooltip]] + $text_widget tag bind $tag <Any-Button> [list after $tooltipDelay [list destroy ${tag}_$text_widget.tooltip]] } -# ::utils::tooltip::Enter -# -# Handles the mouse entering a button which has a tooltip. -# -proc ::utils::tooltip::Enter {button} { - variable showToolTips - variable enteredWidget - variable tooltipDelay - - if {! $showToolTips} { return } - set enteredWidget $button - after $tooltipDelay [list ::utils::tooltip::Check $button] -} - - -# ::utils::tooltip::Check +# ::utils::tooltip::Show # # Called a set time after the mouse has entered a button with a -# tooltip, to check if it is still there. If so, the tooltip -# message is displayed. +# tooltip, to display a tooltip if necesarry. # -proc ::utils::tooltip::Check {button} { - variable enteredWidget - - if {$enteredWidget != $button} { - # The mouse cursor has moved somewhere else; display no tooltip +proc ::utils::tooltip::Show {button text} { + global tcl_platform + + if { [string match $button* [winfo containing [winfo pointerx .] [winfo pointery .]] ] == 0 } { return } - - if {! [info exists ::utils::tooltip::message($button)]} { return } - - .tooltip.text configure -text [tr $::utils::tooltip::message($button)] - set x [winfo pointerx .] - set y [winfo pointery .] - incr x 10 - incr y 4 - catch {wm transient .tooltip [winfo toplevel $button]} - - # make the tooltip visible - set maxw [ winfo vrootwidth .] - set maxh [ winfo vrootheight .] - set w [winfo reqwidth .tooltip] - set h [winfo reqheight .tooltip] - if { [expr $x + $w] > $maxw } { - set x [expr $maxw - $w] + + catch {destroy $button.tooltip} + + set scrh [winfo screenheight $button] + set scrw [winfo screenwidth $button] + set tooltip [toplevel $button.tooltip -bd 1 -bg black] + wm geometry $tooltip +$scrh+$scrw + wm overrideredirect $tooltip 1 + + if {$tcl_platform(platform) == {windows}} { + wm attributes $tooltip -topmost 1 } - if { [expr $y + $h] > $maxh } { - set y [expr $maxh - $h] + pack [label $tooltip.label -bg lightyellow -fg black -text $text -justify left] + + set width [winfo reqwidth $tooltip.label] + set height [winfo reqheight $tooltip.label] + + # Is the pointer in the bottom half of the screen? + set pointer_below_midline [expr [winfo pointery .] > [expr [winfo screenheight .] / 2.0]] + # Tooltip is centred horizontally on pointer. + set positionX [expr [winfo pointerx .] - round($width / 2.0)] + # Tooltip is displayed above or below depending on pointer Y position. + set positionY [expr [winfo pointery .] + 35 * ($pointer_below_midline * -2 + 1) - round($height / 2.0)] + + # Ad-hockery: Set positionX so the entire tooltip widget will be displayed. + # Simplified slightly and modified to handle horizontally-centred tooltips and the left screen edge. + if {[expr $positionX + $width] > [winfo screenwidth .]} { + set positionX [expr [winfo screenwidth .] - $width] + } elseif {$positionX < 0} { + set positionX 0 } - - catch {wm geometry .tooltip +$x+$y} - wm deiconify .tooltip - raise .tooltip - - # Automatically erase tooltip after a short delay - after 15000 [ list ::utils::tooltip::Leave $button ] -} + wm geometry $tooltip [join "$width x $height + $positionX + $positionY" {}] + raise $tooltip -# ::utils::tooltip::Leave -# -# Handles the mouse leaving a button which has a tooltip. -# -proc ::utils::tooltip::Leave {button} { - after cancel [ list ::utils::tooltip::Leave $button ] - variable showToolTips - if {! $showToolTips} { return } - wm withdraw .tooltip - after cancel [list ::utils::tooltip::Check $button] + # Defeat rare artifact by passing mouse over a tooltip to destroy it. + bind $button.tooltip <Any-Enter> {destroy %W} + bind $button.tooltip <Any-Leave> {destroy %W} } # ::utils::tooltip::ToWidth @@ -148,14 +118,14 @@ proc ::utils::tooltip::Leave {button} { proc ::utils::tooltip::trimWidth { msg } { set ret "" foreach line [split $msg "\n"] { - + if {[string length $line] < $::utils::tooltip::tooltipWidth} { append ret "$line\n" continue } else { # must split the line set words [split $line " "] - + while {[llength $words] > 0} { set tmp [lindex $words 0] set words [lreplace $words 0 0] @@ -165,7 +135,6 @@ proc ::utils::tooltip::trimWidth { msg } { } append ret $tmp "\n" } - } } return [string trim $ret] -- 2.1.4 ------------------------------------------------------------------------------ _______________________________________________ Scid-users mailing list Scid-users@lists.sourceforge.net https://lists.sourceforge.net/lists/listinfo/scid-users
