[[ [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 which 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: [http://www.satisoft.com/tcltk/toolbutton/toolbutton1.gif] Toolbuttons under Windows XP using "lightsteelblue" background: [http://www.satisoft.com/tcltk/toolbutton/toolbutton2.gif] '''NOTE:''' Both of the example images show the second button from the left in "mouse over" mode using images from the [ICONS] ''Klassic'' theme. ---- Have you considered submitting this package to [tklib] for general distribution? ---- #=======================================================================# # 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 "::toolbutton::setMode $widget enter" bind $widget.c "::toolbutton::setMode $widget leave" bind $widget.c "::toolbutton::setMode $widget down" bind $widget.c "::toolbutton::action $widget" bind $widget "::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 "::toolbutton::toolbuttonHelpDelay $widget" bind $widget "::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 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 ---- [MG] - 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 that which are fairly small. You can get the effect of 'seperators' in the toolbar by just adding frame .tb.sep1 -background #999999 -relief sunken -width 1 pack .tb.sep1 -fill y -side left -padx 2 ---- [Category Package] | [Category GUI]