toolbutton
[ 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 that others may find useful.
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:-
- The buttons are flat until the mouse pointer is over when they are displayed with rounded corners/relief.
- When the button is depressed a darker, slightly sunken refief is displayed.
- When the button is disabled the image is displayed in monochrome.
- The button face and shading colours are (by default) based on the normal button widget background colour.
- An alternative background colour can be specified.
- Optional pop-up (balloon) help may be specified.
The code has been tested under Windows XP and Unix/X-Windows/CDE.
Toolbuttons under Windows XP using default background:
Toolbuttons under Windows XP using "lightsteelblue" background:
NOTE: Both of the example images show the second button from the left in "mouse over" mode using images from the ICONS Klassic theme.
Q: Have you considered submitting this package to tklib for general distribution?
LV When I attempt to run the example below, using this version of toolbutton.tcl and icons 1.2, I get this error:
ERROR: Invalid file (tkIcons)
while executing
"error "ERROR: Invalid file ($file)""
(procedure "::icons::icons" line 43)
invoked from within
"::icons::icons create {
navback22
navforward22
navhome22
actreload22
edit22
editcut22
editcopy22
editpaste22
filen..."
invoked from within
"set icons [::icons::icons create {
navback22
navforward22
navhome22
actreload22
edit22
editcut22
editcopy22
editpaste2..."
(file "/tmp/toolbutton_demo.tcl" line 33)[ adavis ] By default ICONS will look for the "tkIcons" file in the directory given by the "info library" command. Is this where you have put this file?
After I turned toolbutton.tcl into a package (by putting the code itself into the file toolbutton.tcl, placing that file into the $prefix/lib/toolbutton-1.0/ directory, and then creating the file pkgIndex.tcl, and placing inside it the line:
package ifneeded toolbutton 1.0 [list source [file join $dir toolbutton.tcl]]
I am finding the slightly modified version of the example is now working.
[ adavis ] 24th March 2004 - Fixed typo in "namespace export" command.
#=======================================================================#
# 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 that #
# 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 that 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 toolbutton
}
#=======================================================================#
# 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. #
#================================#
#--------------------------------------------#
# This example assumes that the "toolbutton" #
# code is already loaded, either by... #
# #
# package require toolbutton #
# ...or... #
# source toolbutton.tcl #
#--------------------------------------------#
#-------------------------#
# Dummy callback command. #
#-------------------------#
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
package require toolbutton ;# If you have taken the above code
# and turned it into a normal package;
# otherwise, try replacing this line
# with a "source toolbutton.tcl" line.
package require Tk
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 .fMG - a much simpler way to do something like this with Tk 8.4, is to use...
frame .tb pack .tb -padx 5 -side left button .tb.b -relief flat -overrelief raised -height 20 -width 20 -image $yourIconHere pack .tb.b -side left
That doesn't include balloon help, but there are a lot of procs on the Wiki for handling balloon help that are fairly small. You can get the effect of 'separators' in the toolbar by just adding
frame .tb.sep1 -background #999999 -relief sunken -width 1 pack .tb.sep1 -fill y -side left -padx 2
[ adavis ] I think you are slightly missing the point of toolbutton. This command creates buttons with rounded corners and a rounded relief effect similar to the buttons found in some Windows XP applications (for example, Internet Explorer). I think this style looks a little less "clunky" than the standard square Tk buttons. toolbutton will produce this XP style toolbutton for any platform (for example: Unix (KDE/CDE etc.)).
DKF: Sure, but you're not adhering to the platform look but instead building a particular platform's look such that everyone uses it. That's at variance with the way that Tk's operated for years. Why not contribute to getting the Tile theming engine working well enough for inclusion in the core instead?
[ adavis ] I'm not suggesting that everybody should use this, or that it sould be part of the standard TK look. I'd noticed recently that a number of applications (Including Mircosoft's own products) do not always follow the normal platform look, so maybe a slavish adherence to a particular platform look will give way to a Corporate/Brand look, such that applications always look the same regardless of platform (A trend towards differentiating products by having a "unique" look?). Anyway, I did this for myself and thought it may be something that others may find useful - The "Spirit Of The Wiki" as I understand it. I think Tile is a great idea and I fully intend to make use of it in the future - As to contributing? I'd like to, but my skills are nowhere near good enough.
DKF: You'd be surprised how good your skills are. Contributing doesn't just mean writing C code! It can also be helping write a test suite (i.e. Tcl scripting using the tcltest package) or trying things out and working out what actually works (a different sort of testing) or just writing documentation (which has to be done but doesn't require deep C hacking in the slightest.) And the best way to improve your skills is to just try to do things. Sure you'll make some mistakes along the way, but we all do that. :^) Learn from them (like the rest of us) and you become better overall.