#----------------------------------------------------------------------
#
# psballoon.tcl,
# Procedures to create help message balloons or display balloons for
# listboxes and labels that can't display all of their contents.
#
# Copyright (c) 2003, Peter Spjuth (peter.spjuth@gmail.com)
#
# Permission is granted to use this code under the same terms as
# for the Tcl core code.
#
#----------------------------------------------------------------------
# $Revision: 1.1 $
#----------------------------------------------------------------------
package provide psballoon 1.0
namespace eval psballoon {
variable balloon
set balloon(pending) 0
set balloon(created) 0
set balloon(id) ""
namespace export addBalloon
}
# Do some simple formatting, to be able to have cleaner text in source
proc psballoon::Fmt {msg} {
# Remove any newlines.
set msg [regsub -all "\n" $msg " "]
# Remove multiple whitespace
set msg [regsub -all {\s+} $msg " "]
set msg [string trim $msg]
# Any explicitly requested newlines?
set msg [regsub -all {\\n\s*} $msg "\n"]
# Further line breaks by length?
set lines {}
foreach line [split $msg \n] {
while {[string length $line] > 80} {
# There should be no path through this loop that does not
# shorten $line
set ix [string last " " $line 80]
if {$ix < 0} {
set ix [string first " " $line]
if {$ix < 0} {
# Just cut at 80
set ix 80
}
}
if {$ix == 0} {
set line [string trim $line]
} else {
lappend lines [string range $line 0 $ix-1]
set line [string range $line $ix+1 end]
}
}
lappend lines $line
}
set msg [join $lines \n]
return $msg
}
proc psballoon::addBalloon {W args} {
variable balloon
set msg [lindex $args end]
set args [lrange $args 0 end-1]
# Request for formatting
if {"-fmt" in $args && $msg ne ""} {
set msg [Fmt $msg]
}
set c [winfo class $W]
if {$msg == "" && $c != "Listbox" && $c != "Label"} {
error "Missing message to balloon for $W ($c)"
}
set balloon(msg,$W) $msg
bind $W <Enter> {
set ::psballoon::balloon(pending) 1
set ::psballoon::balloon(created) 0
set ::psballoon::balloon(id) [after 500 {psballoon::createBalloon %W %x %y}]
}
bind $W <Button> {
psballoon::killBalloon
}
bind $W <Leave> {
psballoon::killBalloon
}
bind $W <Motion> {
if {$::psballoon::balloon(pending) == 1} {
after cancel $::psballoon::balloon(id)
}
if {$::psballoon::balloon(created) == 1} {
psballoon::killBalloon
}
set ::psballoon::balloon(id) [after 500 {psballoon::createBalloon %W %x %y}]
set ::psballoon::balloon(pending) 1
}
}
proc psballoon::killBalloon {} {
variable balloon
if {$balloon(pending) == 1} {
after cancel $balloon(id)
}
if {[winfo exists .balloon] == 1} {
destroy .balloon
}
set balloon(created) 0
set balloon(pending) 0
}
# Measure display width needed for a text with line breaks
proc psballoon::Measure {font txt} {
set len 0
foreach line [split $txt \n] {
set lw [font measure $font $line]
if {$lw > $len} {
set len $lw
}
}
return $len
}
# Returns a list of minX maxX for each screen.
# maxX are exclusive and normally equal to the next minX
proc psballoon::FigureOutScreenWidths {W} {
set screens {}
# Range of X over multiple windows
set minX [winfo vrootx $W]
set maxX [expr {$minX + [winfo vrootwidth $W]}]
set sW [winfo screenwidth $W]
# Guess: If minX is negative, there is a screen from minX to 0
if {$minX < 0} {
lappend screens $minX 0
}
# Guess: Main screen is in the middle if three
# Main screen is 0 to screenWidth
lappend screens 0 $sW
# Guess: If maxX is larger than screen width (main screen), there
# is one more screen to the right
if {$maxX > $sW} {
lappend screens $sW $maxX
}
return $screens
}
proc psballoon::createBalloon {W mx my} {
variable balloon
if { ! [winfo exists $W]} {
return
}
if {$balloon(created) == 0} {
# Figure out widget's font
if {[catch {set font [$W cget -font]}]} {
set font [ttk::style lookup [winfo class $W] -font]
}
# Fallback to something reasonable if font fails.
if {$font eq ""} {
set font TkDefaultFont
}
set ww [winfo width $W]
set ih [winfo height $W]
if {[winfo class $W] in {TLabelframe Labelframe}} {
# Put it below the label, not the entire widget.
# 1.5 font heights is a reasonable guess
set fh [font metrics $font -linespace]
set ih [expr {$fh * 3 /2 }]
# Below cursor at least
if {$ih <= $my} {
set ih [expr {$my + 5}]
}
}
set ix 0
set iy 0
set create 1
set msg $balloon(msg,$W)
if {$msg == ""} {
switch [winfo class $W] {
Listbox {
set i [$W index @$mx,$my]
set msg [$W get $i]
foreach {ix iy iw ih} [$W bbox $i] {break}
}
Label {
set msg [$W cget -text]
set iw [Measure $font $msg]
}
}
# Don't create a balloon if the text is fully visible.
set create [expr {$iw > $ww - 8}]
} else {
if {[string index $msg 0] eq "\["} {
set msg [subst -novariables -nobackslashes $msg]
}
set iw [Measure $font $msg]
}
if {$create} {
set x [expr {[winfo rootx $W] + $ix}]
set y [expr {[winfo rooty $W] + $iy + $ih + 2}]
# Limits of current screen.
foreach {minX maxX} [FigureOutScreenWidths $W] {
if {$minX <= $x && $x < $maxX} break
}
# Move it to the left as needed to fit on screen
if {$x + $iw + 8 > $maxX} {
set x [expr {$maxX - $iw - 8}]
}
# TBD, option to use a frame in parent instead?
toplevel .balloon -bg black
wm overrideredirect .balloon 1
label .balloon.l \
-text $msg -relief flat -font $font -justify left \
-bg #ffffaa -fg black -padx 2 -pady 0 -anchor "w"
pack .balloon.l -side left -padx 1 -pady 1
wm geometry .balloon +${x}+${y}
set balloon(created) 1
}
}
}