You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
440 lines
15 KiB
Plaintext
440 lines
15 KiB
Plaintext
#-------------------------------------------------------------------------------
|
|
# Extbutton
|
|
#-------------------------------------------------------------------------------
|
|
# This [incr Widget] is pretty simple - it just extends the behavior of
|
|
# the Tk button by allowing the user to add a bitmap or an image, which
|
|
# can be placed at various locations relative to the text via the -imagepos
|
|
# configuration option.
|
|
#
|
|
#-------------------------------------------------------------------------------
|
|
# IMPORTANT NOTE: This [incr Widget] will only work with Tk 8.4 or later.
|
|
#
|
|
#-------------------------------------------------------------------------------
|
|
# AUTHOR: Chad Smith E-mail: csmith@adc.com, itclguy@yahoo.com
|
|
#-------------------------------------------------------------------------------
|
|
# Permission to use, copy, modify, distribute, and license this software
|
|
# and its documentation for any purpose is hereby granted as long as this
|
|
# comment block remains intact.
|
|
#-------------------------------------------------------------------------------
|
|
|
|
#
|
|
# Default resources
|
|
#
|
|
option add *Extbutton.borderwidth 2 widgetDefault
|
|
option add *Extbutton.relief raised widgetDefault
|
|
|
|
#
|
|
# Usual options
|
|
#
|
|
itk::usual Extbutton {
|
|
keep -cursor -font
|
|
}
|
|
|
|
itcl::class iwidgets::Extbutton {
|
|
inherit itk::Widget
|
|
|
|
constructor {args} {}
|
|
|
|
itk_option define -activebackground activeBackground Foreground #ececec
|
|
itk_option define -bd borderwidth BorderWidth 2
|
|
itk_option define -bitmap bitmap Bitmap {}
|
|
itk_option define -command command Command {}
|
|
itk_option define -defaultring defaultring DefaultRing 0
|
|
itk_option define -defaultringpad defaultringpad Pad 4
|
|
itk_option define -image image Image {}
|
|
itk_option define -imagepos imagePos Position w
|
|
itk_option define -relief relief Relief raised
|
|
itk_option define -state state State normal
|
|
itk_option define -text text Text {}
|
|
|
|
public method invoke {} {eval $itk_option(-command)}
|
|
public method flash {}
|
|
|
|
private method changeColor {event_}
|
|
private method sink {}
|
|
private method raise {} {configure -relief $_oldValues(-relief)}
|
|
|
|
private variable _oldValues
|
|
}
|
|
|
|
|
|
#
|
|
# Provide the usual lowercase access command.
|
|
#
|
|
proc iwidgets::extbutton {path_ args} {
|
|
uplevel iwidgets::Extbutton $path_ $args
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# OPTION: -bd
|
|
#
|
|
# DESCRIPTION: This isn't a new option. Similar to -image, we just need to
|
|
# repack the frame when the borderwidth changes. This option is kept by
|
|
# the private reliefframe component.
|
|
#-------------------------------------------------------------------------------
|
|
itcl::configbody iwidgets::Extbutton::bd {
|
|
pack $itk_component(frame) -padx 4 -pady 4
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# OPTION: -bitmap
|
|
#
|
|
# DESCRIPTION: This isn't a new option - we just need to reset the -image option
|
|
# so that the user can toggle back and forth between images and bitmaps.
|
|
# Otherwise, the image will take precedence and the user will be unable to
|
|
# change to a bitmap without manually setting the label component's -image to
|
|
# an empty string. This option is kept by the image component.
|
|
#-------------------------------------------------------------------------------
|
|
itcl::configbody iwidgets::Extbutton::bitmap {
|
|
if {$itk_option(-bitmap) == ""} {
|
|
return
|
|
}
|
|
if {$itk_option(-image) != ""} {
|
|
configure -image {}
|
|
}
|
|
pack $itk_component(frame) -padx 4 -pady 4
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# OPTION: -command
|
|
#
|
|
# DESCRIPTION: Invoke the given command to simulate the Tk button's -command
|
|
# option. The command is invoked on <ButtonRelease-1> events only or by
|
|
# direct calls to the public invoke() method.
|
|
#-------------------------------------------------------------------------------
|
|
itcl::configbody iwidgets::Extbutton::command {
|
|
if {$itk_option(-command) == ""} {
|
|
return
|
|
}
|
|
|
|
# Only create the tag binding if the button is operable.
|
|
if {$itk_option(-state) == "normal"} {
|
|
bind $this-commandtag <ButtonRelease-1> [itcl::code $this invoke]
|
|
}
|
|
|
|
# Associate the tag with each component if it's not already done.
|
|
if {[lsearch [bindtags $itk_interior] $this-commandtag] == -1} {
|
|
foreach component [component] {
|
|
bindtags [component $component] \
|
|
[linsert [bindtags [component $component]] end $this-commandtag]
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# OPTION: -defaultring
|
|
#
|
|
# DESCRIPTION: Controls display of the sunken frame surrounding the button.
|
|
# This option simulates the pushbutton iwidget -defaultring option.
|
|
#-------------------------------------------------------------------------------
|
|
itcl::configbody iwidgets::Extbutton::defaultring {
|
|
switch -- $itk_option(-defaultring) {
|
|
1 {set ring 1}
|
|
0 {set ring 0}
|
|
default {
|
|
error "Invalid option for -defaultring: \"$itk_option(-defaultring)\". \
|
|
Should be 1 or 0."
|
|
}
|
|
}
|
|
|
|
if ($ring) {
|
|
$itk_component(ring) configure -borderwidth 2
|
|
pack $itk_component(reliefframe) -padx $itk_option(-defaultringpad) \
|
|
-pady $itk_option(-defaultringpad)
|
|
} else {
|
|
$itk_component(ring) configure -borderwidth 0
|
|
pack $itk_component(reliefframe) -padx 0 -pady 0
|
|
}
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# OPTION: -defaultringpad
|
|
#
|
|
# DESCRIPTION: The pad distance between the ring and the button.
|
|
#-------------------------------------------------------------------------------
|
|
itcl::configbody iwidgets::Extbutton::defaultringpad {
|
|
# Must be an integer.
|
|
if ![string is integer $itk_option(-defaultringpad)] {
|
|
error "Invalid value specified for -defaultringpad:\
|
|
\"$itk_option(-defaultringpad)\". Must be an integer."
|
|
}
|
|
|
|
# Let's go ahead and make the maximum padding 20 pixels. Surely no one
|
|
# will want more than that.
|
|
if {$itk_option(-defaultringpad) < 0 || $itk_option(-defaultringpad) > 20} {
|
|
error "Value for -defaultringpad must be between 0 and 20."
|
|
}
|
|
|
|
# If the ring is displayed, repack it according to the new padding amount.
|
|
if {$itk_option(-defaultring)} {
|
|
pack $itk_component(reliefframe) -padx $itk_option(-defaultringpad) \
|
|
-pady $itk_option(-defaultringpad)
|
|
}
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# OPTION: -image
|
|
#
|
|
# DESCRIPTION: This isn't a new option - we just need to repack the frame after
|
|
# the image is changed in case the size is different than the previous one.
|
|
# This option is kept by the image component.
|
|
#-------------------------------------------------------------------------------
|
|
itcl::configbody iwidgets::Extbutton::image {
|
|
pack $itk_component(frame) -padx 4 -pady 4
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# OPTION: -imagepos
|
|
#
|
|
# DESCRIPTION: Allows the user to move the image to different locations areound
|
|
# the text. Valid options are n, nw, ne, s, sw, se e, en, es, w, wn or ws.
|
|
#-------------------------------------------------------------------------------
|
|
itcl::configbody iwidgets::Extbutton::imagepos {
|
|
switch -- $itk_option(-imagepos) {
|
|
n {set side top; set anchor center}
|
|
ne {set side top; set anchor e}
|
|
nw {set side top; set anchor w}
|
|
|
|
s {set side bottom; set anchor center}
|
|
se {set side bottom; set anchor e}
|
|
sw {set side bottom; set anchor w}
|
|
|
|
w {set side left; set anchor center}
|
|
wn {set side left; set anchor n}
|
|
ws {set side left; set anchor s}
|
|
|
|
e {set side right; set anchor center}
|
|
en {set side right; set anchor n}
|
|
es {set side right; set anchor s}
|
|
|
|
default {
|
|
error "Invalid option: \"$itk_option(-imagepos)\". \
|
|
Must be n, nw, ne, s, sw, se e, en, es, w, wn or ws."
|
|
}
|
|
}
|
|
|
|
pack $itk_component(image) -side $side -anchor $anchor
|
|
pack $itk_component(frame) -padx 4 -pady 4
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# OPTION: -relief
|
|
#
|
|
# DESCRIPTION: Move the frame component according to the relief to simulate
|
|
# the text in a Tk button when its relief is changed.
|
|
#-------------------------------------------------------------------------------
|
|
itcl::configbody iwidgets::Extbutton::relief {
|
|
update idletasks
|
|
switch -- $itk_option(-relief) {
|
|
flat - ridge - groove {
|
|
place $itk_component(frame) -x 5 -y 5
|
|
}
|
|
|
|
raised {
|
|
place $itk_component(frame) -x 4 -y 4
|
|
}
|
|
|
|
sunken {
|
|
place $itk_component(frame) -x 6 -y 6
|
|
}
|
|
|
|
default {
|
|
error "Invalid option: \"$itk_option(-relief)\". \
|
|
Must be flat, ridge, groove, raised, or sunken."
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# OPTION: -state
|
|
#
|
|
# DESCRIPTION: Simulate the button's -state option.
|
|
#-------------------------------------------------------------------------------
|
|
itcl::configbody iwidgets::Extbutton::state {
|
|
switch -- $itk_option(-state) {
|
|
disabled {
|
|
bind $itk_interior <Enter> { }
|
|
bind $itk_interior <Leave> { }
|
|
bind $this-sunkentag <1> { }
|
|
bind $this-raisedtag <ButtonRelease-1> { }
|
|
bind $this-commandtag <ButtonRelease-1> { }
|
|
set _oldValues(-fg) [cget -foreground]
|
|
set _oldValues(-cursor) [cget -cursor]
|
|
configure -foreground $itk_option(-disabledforeground)
|
|
configure -cursor "X_cursor red black"
|
|
}
|
|
|
|
normal {
|
|
bind $itk_interior <Enter> [itcl::code $this changeColor enter]
|
|
bind $itk_interior <Leave> [itcl::code $this changeColor leave]
|
|
bind $this-sunkentag <1> [itcl::code $this sink]
|
|
bind $this-raisedtag <ButtonRelease-1> [itcl::code $this raise]
|
|
bind $this-commandtag <ButtonRelease-1> [itcl::code $this invoke]
|
|
configure -foreground $_oldValues(-fg)
|
|
configure -cursor $_oldValues(-cursor)
|
|
}
|
|
|
|
default {
|
|
error "Bad option for -state: \"$itk_option(-state)\". Should be\
|
|
normal or disabled."
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# OPTION: -text
|
|
#
|
|
# DESCRIPTION: This isn't a new option. Similar to -image, we just need to
|
|
# repack the frame when the text changes.
|
|
#-------------------------------------------------------------------------------
|
|
itcl::configbody iwidgets::Extbutton::text {
|
|
pack $itk_component(frame) -padx 4 -pady 4
|
|
}
|
|
|
|
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# CONSTRUCTOR
|
|
#-------------------------------------------------------------------------------
|
|
itcl::body iwidgets::Extbutton::constructor {args} {
|
|
# Extbutton will not work with versions of Tk less than 8.4 (the
|
|
# -activeforeground option was added to the Tk label widget in 8.4, for
|
|
# example). So disallow its use unless the right wish is being used.
|
|
if {$::tk_version < 8.4} {
|
|
error "The extbutton \[incr Widget\] can only be used with versions of\
|
|
Tk greater than 8.3.\nYou're currently using version $::tk_version."
|
|
}
|
|
|
|
# This frame is optionally displayed as a "default ring" around the button.
|
|
itk_component add ring {
|
|
frame $itk_interior.ring -relief sunken
|
|
} {
|
|
rename -background -ringbackground ringBackground Background
|
|
}
|
|
|
|
# Add an outer frame for the widget's relief. Ideally we could just keep
|
|
# the hull's -relief, but it's too tricky to handle relief changes.
|
|
itk_component add -private reliefframe {
|
|
frame $itk_component(ring).f
|
|
} {
|
|
rename -borderwidth -bd borderwidth BorderWidth
|
|
keep -relief
|
|
usual
|
|
}
|
|
|
|
# This frame contains the image and text. It will be moved slightly to
|
|
# simulate the text in a Tk button when the button is depressed/raised.
|
|
itk_component add frame {
|
|
frame $itk_component(reliefframe).f -borderwidth 0
|
|
}
|
|
|
|
itk_component add image {
|
|
label $itk_component(frame).img -borderwidth 0
|
|
} {
|
|
keep -bitmap -background -image
|
|
rename -foreground -bitmapforeground foreground Foreground
|
|
}
|
|
|
|
itk_component add label {
|
|
label $itk_component(frame).txt -borderwidth 0
|
|
} {
|
|
keep -activeforeground -background -disabledforeground
|
|
keep -font -foreground -justify -text
|
|
}
|
|
|
|
pack $itk_component(image) $itk_component(label) -side left -padx 6 -pady 4
|
|
pack $itk_component(frame) -padx 4 -pady 4
|
|
pack $itk_component(reliefframe) -fill both
|
|
pack $itk_component(ring) -fill both
|
|
|
|
# Create a couple of binding tags for handling relief changes. Then
|
|
# add these tags to each component.
|
|
foreach component [component] {
|
|
bindtags [component $component] \
|
|
[linsert [bindtags [component $component]] end $this-sunkentag]
|
|
bindtags [component $component] \
|
|
[linsert [bindtags [component $component]] end $this-raisedtag]
|
|
}
|
|
|
|
set _oldValues(-fg) [cget -foreground]
|
|
set _oldValues(-cursor) [cget -cursor]
|
|
|
|
eval itk_initialize $args
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# METHOD: flash
|
|
#
|
|
# ACCESS: public
|
|
#
|
|
# DESCRIPTION: Simulate the Tk button flash command.
|
|
#
|
|
# ARGUMENTS: none
|
|
#-------------------------------------------------------------------------------
|
|
itcl::body iwidgets::Extbutton::flash {} {
|
|
set oldbg [cget -background]
|
|
config -background $itk_option(-activebackground)
|
|
update idletasks
|
|
|
|
after 50; config -background $oldbg; update idletasks
|
|
after 50; config -background $itk_option(-activebackground); update idletasks
|
|
after 50; config -background $oldbg
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# METHOD: changeColor
|
|
#
|
|
# ACCESS: private
|
|
#
|
|
# DESCRIPTION: This method is invoked by <Enter> and <Leave> events to change
|
|
# the background and foreground colors of the widget.
|
|
#
|
|
# ARGUMENTS: event_ --> either "enter" or "leave"
|
|
#-------------------------------------------------------------------------------
|
|
itcl::body iwidgets::Extbutton::changeColor {event_} {
|
|
switch -- $event_ {
|
|
enter {
|
|
set _oldValues(-bg) [cget -background]
|
|
set _oldValues(-fg) [cget -foreground]
|
|
configure -background $itk_option(-activebackground)
|
|
configure -foreground $itk_option(-activeforeground)
|
|
}
|
|
leave {
|
|
configure -background $_oldValues(-bg)
|
|
configure -foreground $_oldValues(-fg)
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# METHOD: sink
|
|
#
|
|
# ACCESS: private
|
|
#
|
|
# DESCRIPTION: This method is invoked on <1> mouse events. It saves the
|
|
# current relief for later restoral and configures the relief to sunken if
|
|
# it isn't already sunken.
|
|
#
|
|
# ARGUMENTS: none
|
|
#-------------------------------------------------------------------------------
|
|
itcl::body iwidgets::Extbutton::sink {} {
|
|
set _oldValues(-relief) [cget -relief]
|
|
if {$_oldValues(-relief) == "sunken"} {
|
|
return
|
|
}
|
|
configure -relief sunken
|
|
}
|