71 lines
2.2 KiB
Tcl
71 lines
2.2 KiB
Tcl
|
# Ballon Help routines
|
||
|
|
# Set the global variable TKG(balloons) to 0 to disable balloon help.
|
||
|
|
|
||
|
|
# Set up general bindings for widgets that will have balloon help
|
||
|
|
bind balloon <Enter> {after 1000 {TKGDoBalloon %W}}
|
||
|
|
bind balloon <Leave> {TKGPopBalloon %W 1}
|
||
|
|
bind balloon <Any-Button> {TKGPopBalloon %W}
|
||
|
|
|
||
|
|
# Set up bindings for a help balloon
|
||
|
|
# w - the widget for which the help balloon provides help.
|
||
|
|
# text - the contents of the balloon
|
||
|
|
proc TKGBalloonBind {w text} {
|
||
|
|
global TKG
|
||
|
|
if {[lsearch [bindtags $w] balloon] == -1} {
|
||
|
|
bindtags $w [concat balloon [bindtags $w]]
|
||
|
|
}
|
||
|
|
set TKG(balloontext,$w) $text
|
||
|
|
}
|
||
|
|
|
||
|
|
# Produce balloon if appropriate
|
||
|
|
proc TKGDoBalloon {w} {
|
||
|
|
global TKG
|
||
|
|
set b .tkgballoon
|
||
|
|
# are help balloons enabled?
|
||
|
|
if {[info exists TKG(balloons)] && !$TKG(balloons)} return
|
||
|
|
if {[winfo exists $b]} return
|
||
|
|
# has the pointer already left the window?
|
||
|
|
if {![string match $w* [eval winfo containing [winfo pointerxy .]]]} {
|
||
|
|
return
|
||
|
|
}
|
||
|
|
toplevel $b
|
||
|
|
wm withdraw $b
|
||
|
|
wm overrideredirect $b 1
|
||
|
|
if {![info exists TKG(balloonbackground)]} {
|
||
|
|
set TKG(balloonbackground) \#ffcf30
|
||
|
|
}
|
||
|
|
grid [label $b.lab -textvariable TKG(balloontext,$w) \
|
||
|
|
-bg $TKG(balloonbackground) \
|
||
|
|
-borderwidth 2 -relief ridge]
|
||
|
|
update idletasks
|
||
|
|
# compute position, staying on the screen and adjacent to the
|
||
|
|
# widget in question
|
||
|
|
set x [winfo rootx $w]
|
||
|
|
set y [expr [winfo rooty $w] - [winfo reqheight $b]]
|
||
|
|
if {$y < 0} {
|
||
|
|
set y [expr [winfo rooty $w] + [winfo height $w]]
|
||
|
|
}
|
||
|
|
if {([winfo vrootwidth .] - $x - [winfo reqwidth $b]) < 0} {
|
||
|
|
set x [expr [winfo vrootwidth .] - [winfo reqwidth $b]]
|
||
|
|
}
|
||
|
|
if {([winfo vrootheight .] - $y - [winfo reqheight $b]) < 0} {
|
||
|
|
set y [expr [winfo vrootheight .] - [winfo reqheight $b]]
|
||
|
|
}
|
||
|
|
wm geometry $b +${x}+${y}
|
||
|
|
wm deiconify $b
|
||
|
|
# in fvwm I get the panel occluding the balloon sometimes:
|
||
|
|
after 30 "catch \"raise $b\""
|
||
|
|
}
|
||
|
|
|
||
|
|
# Destroy the help baloon unless it's a leave event and the
|
||
|
|
# pointer is in a child.
|
||
|
|
proc TKGPopBalloon {w {leave 0}} {
|
||
|
|
global TKG
|
||
|
|
after cancel [list TKGDoBalloon $w]
|
||
|
|
if {$leave &&
|
||
|
|
![string compare $w [eval winfo containing [winfo pointerxy .]]]} {
|
||
|
|
return
|
||
|
|
}
|
||
|
|
destroy .tkgballoon
|
||
|
|
}
|