Tk Source Code

Artifact c28697b9bb4b15a6fe688117323f9dddbd93ecee:

Attachment "balloon.tcl" to ticket [3610493fff] added by eugene_cdn 2013-04-11 04:59:07. Also attachment "balloon.tcl" to ticket [3610491fff] added by eugene_cdn 2013-04-11 04:21:52.

---

###############################################
# balloon.tcl - procedures used by balloon help
# Copyright (C) 1996-1997 Stewart Allen
#               2002-2009 Yevgen Ryazanov
#               2000-2007 Andres Garcia
# Adapted for general purpose by Daniel Roche <dan@lectra.com>
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# Usage: SetBalloon window text
###############################################

namespace eval BalloonHelp {

variable Bulle
set Bulle(enable) 1
set Bulle(updatetime) 100

bind Bulle <Enter> {
    if {$BalloonHelp::Bulle(enable)} {
        set BalloonHelp::Bulle(x) %X
        set BalloonHelp::Bulle(y) %Y
        set BalloonHelp::Bulle(id) [after $::BalloonHelp::Bulle(updatetime) {BalloonHelp::balloon %W}]
    }
}

bind Bulle <Leave> {
    BalloonHelp::kill_balloon
}

bind Bulle <Motion> {
    set BalloonHelp::Bulle(x) %X
    set BalloonHelp::Bulle(y) %Y
}

bind Bulle <Button> {
    BalloonHelp::kill_balloon
}

bind Bulle <Destroy> {
    BalloonHelp::delete_balloon %W
}

proc set_balloon {target message} {
    variable Bulle
    if {![info exists Bulle($target)]} {
        bindtags $target "[bindtags $target] Bulle"
    } elseif {![string match $Bulle($target) $message]} {
        catch {destroy .balloon}
    }
    set Bulle($target) $message
}

proc delete_balloon {target} {
    variable Bulle
    if {![info exists Bulle($target)]} {
        return
    }
    unset Bulle($target)
    set bindList   [bindtags $target]
    set bulleIndex [lsearch $bindList Bulle]
    set bindList   [lreplace $bindList $bulleIndex $bulleIndex]
    bindtags $target $bindList

    catch {after cancel $Bulle(id)}
    catch {destroy .balloon}
}

proc kill_balloon {} {
    variable Bulle
    catch {after cancel $Bulle(id)}
    catch {destroy .balloon}
}

proc balloon {target} {
    variable Bulle

    if {[catch {set Bulle($target)} message]} return
    catch {destroy .balloon}

    set cx $Bulle(x)
    set cy $Bulle(y)
    if { $cx == 0 && $cy == 0 } {
        set x [expr [winfo rootx $target] + ([winfo width $target]/2)]
        set y [expr [winfo rooty $target] + [winfo height $target] + 4]
    } else {
        set x [expr $cx + 4]
        set y [expr $cy + 4]
    }

    # if available width is less than 100 pixels, make the balloon
    # 100 pixels wide and move it to the left so it's inside the screen
    set wlength [expr {[winfo screenwidth .] -20 - $x}]
    set minwidth 100
    if { $wlength < $minwidth } {
        set offset [expr {$wlength - $minwidth}]
        incr x $offset
        set wlength $minwidth
    }
    set maxwidth 400
    if { $wlength > $maxwidth } {
        set wlength $maxwidth
    }

    destroy .balloon ;# it is possible to Enter twice w/o leaving
    toplevel .balloon -bg black
    wm overrideredirect .balloon 1
    label .balloon.l -text $message -relief flat -wraplength $wlength -justify left
    pack .balloon.l -side left -padx 1 -pady 1
    wm geometry .balloon +${x}+${y}
} ;# balloon

} ;# namespace BalloonHelp

#
# Public functions
#

proc SetBalloon {target message {updatetime 100} } {
    BalloonHelp::set_balloon $target $message
}

proc UnsetBalloon {target} {
    BalloonHelp::delete_balloon $target
}

proc EnableBalloon {on} {
    set BalloonHelp::Bulle(enable) $on
    if {!$on} {
        catch {BalloonHelp::kill_balloon}
    }
}