class Balloonwidget {
inherit itk::Widget
itk_option define -balloonhelp balloonHelp BalloonHelp ""
private variable balloon_queue ""
private variable destroy_queue ""
public method enter
public method leave
public method balloon
constructor { args } {
bind $itk_component(hull) <Enter> [code $this enter]
bind $itk_component(hull) <Leave> [code $this leave]
eval itk_initialize $args }
}
body Balloonwidget::enter { } {
if {$balloon_queue != ""} {
after cancel $balloon_queue
}
if {$itk_option(-balloonhelp) != ""} {
set balloon_queue [after 750 [code $this balloon]]
}
}
body Balloonwidget::leave { } {
if {$balloon_queue != ""} {
after cancel $balloon_queue
}
set destroy_queue [after 100 {catch {destroy .balloon_help}}]
}
body Balloonwidget::balloon { } {
set t .balloon_help
catch {destroy $t}
toplevel $t
wm overrideredirect $t 1
if {[tk windowingsystem] == "aqua"} {
#unsupported1 style $itk_component(hull) floating sideTitlebar
::tk::unsupported::MacWindowStyle style $t help none
}
label $t.l \
-text " $itk_option(-balloonhelp) " \
-relief solid \
-bd 2 \
-bg gold \
-fg #000000 \
-font font_b
pack $t.l -fill both
set x [expr [winfo pointerx $itk_component(hull)] + 8]
set y [expr [winfo pointery $itk_component(hull)] + 20]
if {[expr $x + [winfo reqwidth $t.l]] > [winfo screenwidth $t.l]} {
set x [expr [winfo screenwidth $t.l] - [winfo reqwidth $t.l] - 2]
}
if {[expr $y + [winfo reqheight $t.l]] > [winfo screenheight $t.l]} {
set y [expr $y - 20 - [winfo reqheight $t.l] - 2]
}
wm geometry $t +$x\+$y
#bind $t <Enter> [list [after cancel $destroy_queue]]
#bind $t <Leave> "catch {destroy .balloon_help}"
}
class Toolbutton {
inherit Balloonwidget
private common groups ; # array
private proc releaseRadioGroup
protected variable mode 0
private variable tags {}
private variable old_group ""
private method enter
private method leave
protected method execute
public method invoke
public method cancel
public method toggle
public method query
itk_option define -image image Image "" {
if {$itk_option(-image) != ""} {
$itk_component(button) configure \
-image $itk_option(-image) \
-width [expr [image width $itk_option(-image)] + 4] \
-height [expr [image height $itk_option(-image)] + 4]
}
}
itk_option define -group group Group "" {
if {$itk_option(-group) != ""} {
# remove from old group
if {$old_group != ""} {
set l_pos [lsearch $group($old_group) $this]
set groups($old_group) [lreplace $groups($old_group) $l_pos $l_pos]
}
# set new group
lappend groups($itk_option(-group)) $this
}
}
itk_option define -disabledimage diabledImage Image ""
itk_option define -activeimage activeImage Image ""
itk_option define -type type Type "amodal"
itk_option define -command command Command ""
itk_option define -state state State "normal" {
# If the toolbutton has been disabled
if {$itk_option(-state) == "disabled"} {
# Show the disabled imgage (if there is one)
if {$itk_option(-disabledimage) != ""} {
$itk_component(button) configure -image $itk_option(-disabledimage)
}
# Trigger "leave"
leave
# Turn the button off
set mode 0
# Remove mouse-over bindings
bind $itk_component(button) <Enter> {}
bind $itk_component(button) <Leave> {}
# Remove 'Button' bindings
set tags [bindtags $itk_component(button)]
set tag_pos [lsearch $tags "Button"]
if {$tag_pos > -1} {
bindtags $itk_component(button) [lreplace $tags $tag_pos $tag_pos]
}
} else {
# else it must be normal!
if {$itk_option(-image) != ""} {
$itk_component(button) configure -image $itk_option(-image)
}
# Don't fiddle with mode!
#set mode 0
# Set up mouse-over bindings
bind $itk_component(button) <Enter> [code $this enter]
bind $itk_component(button) <Leave> [code $this leave]
# Restore 'Button' bindings
set tags [bindtags $itk_component(button)]
if {[lsearch $tags "Button"] == -1} {
set tag_pos [lsearch $tags $itk_component(button)]
incr tag_pos
bindtags $itk_component(button) [linsert $tags $tag_pos "Button"]
}
}
}
constructor { args } { }
}
body Toolbutton::constructor { args } {
# Remove default enter/leave bindings
bind $itk_component(hull) <Enter> {}
bind $itk_component(hull) <Leave> {}
itk_component add button {
button $itk_interior.button \
-relief flat \
-command [code $this execute] \
-takefocus 0 \
-highlightthickness 0
}
pack $itk_component(button)
eval itk_initialize $args
}
body Toolbutton::releaseRadioGroup { a_group a_toolbutton } {
foreach i_toolbutton $groups($a_group) {
if {$i_toolbutton != $a_toolbutton} {
$i_toolbutton cancel
}
}
}
body Toolbutton::enter { } {
Balloonwidget::enter
if {($itk_option(-type) == "amodal") || ($mode == 0)} {
$itk_component(button) configure -relief raised
}
}
body Toolbutton::leave { } {
Balloonwidget::leave
if {($itk_option(-type) == "amodal") || ($mode == 0)} {
$itk_component(button) configure -relief flat
}
}
body Toolbutton::execute { } {
# Take focus to force setting updates
focus $itk_component(button)
if {$itk_option(-type) == "modal"} {
if {$mode == 0} {
set mode 1
$itk_component(button) configure -relief sunk -bg "\#eeeeee" -activebackground "\#eeeeee"
if {[tk windowingsystem] == "aqua"} {
if {$itk_option(-activeimage) != ""} {
$itk_component(button) configure -image $itk_option(-activeimage)
}
}
} else {
set mode 0
$itk_component(button) configure -relief raised -bg "\#dcdcdc" -activebackground "\#dcdcdc"
if {[tk windowingsystem] == "aqua"} {
if {$itk_option(-image) != ""} {
$itk_component(button) configure -image $itk_option(-image)
}
}
}
if {$itk_option(-command) != ""} {
uplevel \#0 $itk_option(-command) $mode
}
} elseif {$itk_option(-type) == "radio"} {
if {$mode == 0} {
set mode 1
# deselect other radios in group
releaseRadioGroup $itk_option(-group) $this
$itk_component(button) configure -relief sunk -bg "\#eeeeee" -activebackground "\#eeeeee"
if {[tk windowingsystem] == "aqua"} {
if {$itk_option(-activeimage) != ""} {
$itk_component(button) configure -image $itk_option(-activeimage)
}
}
if {$itk_option(-command) != ""} {
uplevel \#0 $itk_option(-command) $mode
}
}
} else {
if {$itk_option(-command) != ""} {
uplevel \#0 $itk_option(-command)
}
}
}
body Toolbutton::invoke { { execute "execute" } } {
if {($itk_option(-type) != "amodal")} {
if {$mode == 0} {
set mode 1
$itk_component(button) configure -relief sunk -bg "\#eeeeee" -activebackground "\#eeeeee"
if {[tk windowingsystem] == "aqua"} {
if {$itk_option(-activeimage) != ""} {
$itk_component(button) configure -image $itk_option(-activeimage)
}
}
}
if {$execute == "execute"} {
if {$itk_option(-command) != ""} {
uplevel \#0 $itk_option(-command) $mode
}
}
} else {
if {$execute == "execute"} {
if {$itk_option(-command) != ""} {
uplevel \#0 $itk_option(-command)
}
}
}
}
body Toolbutton::toggle { { execute "execute" } } {
$itk_component(button) invoke $execute
}
body Toolbutton::cancel { { execute "execute" } } {
if {(($itk_option(-type) != "amodal") && ($mode == 1))} {
set mode 0
$itk_component(button) configure -relief flat -bg "\#dcdcdc" -activebackground "\#dcdcdc"
if {[tk windowingsystem] == "aqua"} {
if {$itk_option(-image) != ""} {
$itk_component(button) configure -image $itk_option(-image)
}
}
if {$execute == "execute"} {
if {$itk_option(-command) != ""} {
uplevel \#0 $itk_option(-command) $mode
}
}
}
}
body Toolbutton::query { } {
if {$itk_option(-type) != "amodal"} {
return $mode
} else {
return ""
}
}
usual Toolbutton {}
proc aaa { } {
}
class test {
public method mes
public method queryte
constructor { args } {
# new widigets puts here,
Toolbutton .c \
-balloonhelp "New session" \
-command [code $this queryte]
pack .c
}
}
body test::queryte { } {
# method puts here
}
body test::mes { } {
}