neingeist
/
arduinisten
Archived
1
0
Fork 0
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.
This repo is archived. You can view files and clone it, but cannot push or open issues/pull-requests.

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
}