[ adavis ] I'm a great fan of TCL/TK but, along with a number of others, I feel that TK applications do tend to have a rather "old fashoned" look. While my programming skills are not up to "hacking the core", I have produced a modern style toolbar button.
toolbutton is based on the Adobe Acrobat 6.0 style buttons (Which is a similar style to Windows XP Explorer).
The buttons have the following properties/behaviour:-
NOTE: Both of the example images show the second button from the left in "mouse over" mode using the ICONS Klassic theme.
#=======================================================================#
# SCRIPT : toolbutton.tcl #
# PURPOSE: Create "smooth look" toolbar button. #
# AUTHOR : Adrian Davis #
# VERSION: 1.0 #
#-----------------------------------------------------------------------#
# REQUIREMENTS #
# Tk 8.4 or later. #
#-----------------------------------------------------------------------#
# NAME #
# toolbutton #
# DESCRIPTION #
# toolbutton widget ?option value ...? #
# widget cget option #
# widget configure option value #
# OPTIONS #
# -background #
# Sets background ("base") color for button. By default the #
# background color for the "button" widget is used. All colors #
# used for highlighting/shading of the toolbutton are based on #
# its background color. #
# -command #
# Command to be invoked by toolbutton. #
# -height #
# Height of toolbutton in pixels. By default the height is the #
# height of the specified image. If a height is specified which #
# is smaller than the default, the default will be used instead. #
# -help #
# Text for optional pop-up help. #
# -image #
# Name of image to be used for button. The specified image must #
# exist prior to calling toolbutton. This option is MANDATORY. #
# -state #
# State of button when created. By default the initial state is #
# set to "normal". When the image state is set to "disabled" the #
# toolbutton image changes from color to monochrome. #
# -width #
# Width of toolbutton in pixels. By default the width is the #
# width of the specified image. If a width is specified which is #
# smaller than the default, the default will be used instead. #
#-----------------------------------------------------------------------#
# WIDGET COMMANDS #
# "widget" cget "option" #
# Returns the value of the specified "option" for "widget". #
# "widget" configure "option" "value" #
# Sets the value of the specified "option" to "value" for #
# "widget". The following options may be set:- #
# -background #
# -command #
# -help #
# -state #
#=======================================================================#
#=======================================================================#
# Set-up toolbutton namespace. #
#=======================================================================#
package require Tk 8.4
package provide toolbutton 1.0
namespace eval ::toolbutton {
namespace export toobutton
}
#=======================================================================#
# Main toolbutton creation proc. #
#=======================================================================#
proc ::toolbutton::toolbutton {widget args} {
if {[winfo exists $widget]} {
error "Window name \"$widget\" already exists"
}
namespace eval ::toolbutton::$widget {
variable {}
set (dummy) dummy ;# Coerce into an array.
unset (dummy)
}
set state [::toolbutton::configure $widget $args]
::toolbutton::build $widget
::toolbutton::setMode $widget leave
::toolbutton::setState $widget $state
bind $widget.c <Enter> "::toolbutton::setMode $widget enter"
bind $widget.c <Leave> "::toolbutton::setMode $widget leave"
bind $widget.c <ButtonPress-1> "::toolbutton::setMode $widget down"
bind $widget.c <ButtonRelease-1> "::toolbutton::action $widget"
bind $widget <Destroy> "::toolbutton::destroyHandler $widget"
}
#=======================================================================#
# Configure widget. #
#=======================================================================#
proc ::toolbutton::configure {widget args} {
upvar ::toolbutton::${widget}::{} {}
foreach {option value} [lindex $args 0] {
set ($option) $value
}
if {[info exists (-image)]} {
set iconHeight [image height $(-image)]
set iconWidth [image width $(-image)]
} else {
error "No image specified"
}
if {[info exists (-height)]} {
if {$(-height) < $iconHeight} {
set (-height) $iconHeight
}
} else {
set (-height) $iconHeight
}
if {[info exists (-width)]} {
if {$(-width) < $iconWidth} {
set (-width) $iconWidth
}
} else {
set (-width) $iconWidth
}
if {! [info exists (-state)]} {
set (-state) normal
}
if {! [info exists (-background)]} {
set tmpWidget ".__tmp__"
set count 0
while {[winfo exists $tmpWidget] == 1} {
set tmpWidget ".__tmp__$count"
incr count
}
button $tmpWidget
set (-background) [$tmpWidget cget -background]
destroy $tmpWidget
}
set (canvasHeight) [expr {$(-height) + 6}]
set (canvasWidth) [expr {$(-width) + 6}]
set (x0) [expr {$(canvasWidth) - 1}]
set (x1) [expr {$(canvasWidth) - 2}]
set (x2) [expr {$(canvasWidth) - 3}]
set (x3) [expr {$(canvasWidth) - 4}]
set (y0) [expr {$(canvasHeight) - 1}]
set (y1) [expr {$(canvasHeight) - 2}]
set (y2) [expr {$(canvasHeight) - 3}]
set (y3) [expr {$(canvasHeight) - 4}]
::toolbutton::setbackground $widget
return $(-state)
}
#=======================================================================#
# Build the widget. #
#=======================================================================#
proc ::toolbutton::build {widget} {
upvar ::toolbutton::${widget}::{} {}
frame $widget
canvas $widget.c -height $(canvasHeight) -highlightthickness 0 -width $(canvasWidth) -background $(-background)
$widget.c create image [expr {$(canvasWidth) / 2}] [expr {$(canvasHeight) / 2}] -anchor c -image $(-image) -tags icon
$widget.c create rectangle 0 0 [expr {$(canvasWidth) - 1}] [expr {$(canvasHeight) - 1}] -width 1 -tags {borderColor faceColor}
$widget.c create rectangle 0 0 0 0 -width 1 -tags backgroundColor
$widget.c create line 0 2 2 0 0 2 -width 1 -tags cornerColor1
$widget.c create line 0 1 1 0 0 1 -width 1 -tags cornerColor2
$widget.c create line 1 2 2 1 1 2 -width 1 -tags cornerColor3
$widget.c create rectangle $(x0) 0 $(x0) 0 -width 1 -tags backgroundColor
$widget.c create line $(x0) 2 $(x2) 0 $(x0) 2 -width 1 -tags cornerColor1
$widget.c create line $(x0) 1 $(x1) 0 $(x0) 1 -width 1 -tags cornerColor2
$widget.c create line $(x1) 2 $(x2) 1 $(x1) 2 -width 1 -tags cornerColor3
$widget.c create rectangle 0 $(y0) 0 $(y0) -width 1 -tags backgroundColor
$widget.c create line 0 $(y2) 2 $(y0) 0 $(y2) -width 1 -tags cornerColor1
$widget.c create line 0 $(y1) 1 $(y0) 0 $(y1) -width 1 -tags cornerColor2
$widget.c create line 1 $(y2) 2 $(y1) 1 $(y2) -width 1 -tags cornerColor3
$widget.c create rectangle $(x0) $(y0) $(x0) $(y0) -width 1 -tags backgroundColor
$widget.c create line $(x0) $(y2) $(x2) $(y0) $(x0) $(y2) -width 1 -tags cornerColor1
$widget.c create line $(x0) $(y1) $(x1) $(y0) $(x0) $(y1) -width 1 -tags cornerColor2
$widget.c create line $(x1) $(y2) $(x2) $(y1) $(x1) $(y2) -width 1 -tags cornerColor3
$widget.c create line $(x3) 1 3 1 1 3 1 $(y2) -width 1 -tags relief1Color1
$widget.c create line $(x2) 2 3 2 2 2 2 $(y1) -width 1 -tags relief1Color2
$widget.c create line $(x1) 3 $(x1) $(y2) $(x3) $(y1) 2 $(y1) -width 1 -tags relief2Color1
$widget.c create line $(x2) 3 $(x2) $(y3) $(x3) $(y2) 1 $(y2) -width 1 -tags relief2Color2
pack $widget.c
rename ::$widget ::toolbutton::$widget:frame
proc ::$widget {command args} "eval ::toolbutton::widgetProc $widget \$command \$args"
if {[info exists (-help)]} {
toolbuttonHelpInit $widget
}
}
#=======================================================================#
# Destroy widget. #
#=======================================================================#
proc ::toolbutton::destroyHandler {widget} {
namespace delete ::toolbutton::$widget
}
#=======================================================================#
# Handle widget procedure. #
#=======================================================================#
proc ::toolbutton::widgetProc {widget command args} {
upvar ::toolbutton::${widget}::{} {}
foreach {option value} $args {}
if {! [info exists ($option)]} {
error "Invalid option: $option"
}
switch -- $command {
cget {
return $($option)
}
configure {
switch -- $option {
-command {
set (-command) $value
}
-help {
set (-help) $value
}
-state {
::toolbutton::setState $widget $value
}
-background {
set (-background) $value
::toolbutton::setbackground $widget
::toolbutton::setMode $widget leave
}
default {
error "Invalid option: $option"
}
}
}
default {
error "Invalid command: $command"
}
}
}
#=======================================================================#
# Invoke associated widget "command". #
#=======================================================================#
proc ::toolbutton::action {widget} {
upvar ::toolbutton::${widget}::{} {}
if {$(-state) eq "disabled"} {
return
}
::toolbutton::setMode $widget enter
if {[info exists (-command)]} {
eval $(-command)
}
}
#=======================================================================#
# Set widget mode: "down", "enter", "leave" or "state". #
#=======================================================================#
proc ::toolbutton::setMode {widget mode} {
upvar ::toolbutton::${widget}::{} {}
if {$(-state) eq "disabled" && $mode ne "state"} {
return
}
if {$mode eq "state"} {
set mode "leave"
}
foreach item [lsort [array names {} $mode:*]] {
regexp -- {^.*:(.*)$} $item dummy tag
catch "$widget.c itemconfigure $tag -fill $($item)"
}
$widget.c itemconfigure borderColor -outline $($mode:borderColor)
$widget.c itemconfigure backgroundColor -outline $(backgroundColor)
$widget.c raise icon
}
#=======================================================================#
# Set widget background color(s). #
#=======================================================================#
proc ::toolbutton::setbackground {widget} {
upvar ::toolbutton::${widget}::{} {}
set (background) [winfo rgb . $(-background)]
set (backgroundColor) [::toolbutton::setRGB $(background) 0]
set (leave:faceColor) $(-background)
set (leave:borderColor) $(-background)
set (leave:cornerColor1) $(-background)
set (leave:cornerColor2) $(-background)
set (leave:cornerColor3) $(-background)
set (leave:relief1Color1) $(-background)
set (leave:relief1Color2) $(-background)
set (leave:relief2Color1) $(-background)
set (leave:relief2Color2) $(-background)
set (enter:faceColor) [::toolbutton::setRGB $(background) +4000]
set (enter:borderColor) [::toolbutton::setRGB $(background) -8000]
set (enter:cornerColor1) [::toolbutton::setRGB $(background) -6000]
set (enter:cornerColor2) [::toolbutton::setRGB $(background) -2000]
set (enter:cornerColor3) [::toolbutton::setRGB $(background) +1000]
set (enter:relief1Color1) [::toolbutton::setRGB $(background) +8000]
set (enter:relief1Color2) [::toolbutton::setRGB $(background) +6000]
set (enter:relief2Color1) [::toolbutton::setRGB $(background) -2000]
set (enter:relief2Color2) [::toolbutton::setRGB $(background) 0]
set (down:faceColor) [::toolbutton::setRGB $(background) -6000]
set (down:borderColor) [::toolbutton::setRGB $(background) -14000]
set (down:cornerColor1) [::toolbutton::setRGB $(background) -10000]
set (down:cornerColor2) [::toolbutton::setRGB $(background) -6000]
set (down:cornerColor3) [::toolbutton::setRGB $(background) -3000]
set (down:relief1Color1) [::toolbutton::setRGB $(background) -9000]
set (down:relief1Color2) [::toolbutton::setRGB $(background) -7000]
set (down:relief2Color1) [::toolbutton::setRGB $(background) -4000]
set (down:relief2Color2) [::toolbutton::setRGB $(background) -5000]
}
#=======================================================================#
# Set widget state. #
#=======================================================================#
proc ::toolbutton::setState {widget state} {
upvar ::toolbutton::${widget}::{} {}
switch -- $state {
disabled {
set (-state) $state
$(-image) configure -palette 16
::toolbutton::setMode $widget state
}
normal {
set (-state) $state
$(-image) configure -palette 65536/65536/65536
}
default {
error "Invalid state: $state"
}
}
}
#=======================================================================#
# Shift specified color (rgb) by shift. Positive numbers are lighter, #
# negative numbers darker. #
#=======================================================================#
proc ::toolbutton::setRGB {rgb shift} {
foreach {red blue green} $rgb {}
set red [::toolbutton::shiftColor $red $shift]
set blue [::toolbutton::shiftColor $blue $shift]
set green [::toolbutton::shiftColor $green $shift]
return [format "\#%04X%04X%04X" $red $blue $green]
}
#=======================================================================#
# Shift color (color) by shift and make sure value is in "range". #
#=======================================================================#
proc ::toolbutton::shiftColor {color shift} {
set result [expr {$color + $shift}]
if {$shift < 0} {
if {$result < 0} {
set result 0
}
} else {
if {$result > 65535} {
set result 65535
}
}
return $result
}
#=======================================================================#
# Set-up pop-up help. #
#=======================================================================#
proc ::toolbutton::toolbuttonHelpInit {widget} {
upvar ::toolbutton::${widget}::{} {}
if {! [winfo exists .toolbuttonHelp]} {
toplevel .toolbuttonHelp -background black -borderwidth 1 -relief flat
label .toolbuttonHelp.message -background lightyellow
pack .toolbuttonHelp.message
wm overrideredirect .toolbuttonHelp 1
wm withdraw .toolbuttonHelp
}
bind $widget <Enter> "::toolbutton::toolbuttonHelpDelay $widget"
bind $widget <Leave> "::toolbutton::toolbuttonHelpCancel $widget"
}
proc ::toolbutton::toolbuttonHelpDelay {widget} {
upvar ::toolbutton::${widget}::{} {}
toolbuttonHelpCancel $widget
set (help:delay) [after 300 [list ::toolbutton::toolbuttonHelpShow $widget]]
}
proc ::toolbutton::toolbuttonHelpCancel {widget} {
upvar ::toolbutton::${widget}::{} {}
if {[info exists (help:delay)]} {
after cancel $(help:delay)
unset (help:delay)
}
wm withdraw .toolbuttonHelp
}
proc ::toolbutton::toolbuttonHelpShow {widget} {
upvar ::toolbutton::${widget}::{} {}
.toolbuttonHelp.message configure -text $(-help)
set helpX [expr [winfo rootx $widget] + 10]
set helpY [expr [winfo rooty $widget] + [winfo height $widget]]
wm geometry .toolbuttonHelp +$helpX+$helpY
wm deiconify .toolbuttonHelp
raise .toolbuttonHelp
unset (help:delay)
}
#=======================================================================#
# End of script: toolbutton.tcl #
#=======================================================================#Here is an example...
#================================#
# Example of "toolbutton" usage. #
#================================#
proc mycommand {args} {
puts "This is MYCOMMAND:-"
puts " 0: [lindex $args 0]"
puts " 1: [lindex $args 1]"
}
#--------------------------------------#
# This example uses the ICONS package. #
#--------------------------------------#
package require icons
set icons [::icons::icons create {
navback22
navforward22
navhome22
actreload22
edit22
editcut22
editcopy22
editpaste22
filenew22
fileopen22
filefind22
fileprint22
filesave22
actstop22
}]
set item 1
frame .f
foreach icon $icons {
#----------------------------------------------------------------------------#
# Not all icon images are exactly the same size and, in any case, I like the #
# Acrobat slightly rectangular look, so here I am specifying a specific #
# height and width. #
#----------------------------------------------------------------------------#
::toolbutton::toolbutton .f.tb$item -width 28 -height 24 -help $icon -image ::icon::$icon -command "mycommand $icon $item"
pack .f.tb$item -side left
incr item
}
pack .f