Updated 2006-01-26 02:51:33

if 0 {

Updated on Jan 26 2006

MG Dec 21 2005 - In certain Microsoft programs like MS Word (and probably many others, by MS and other companies), you can right-click on the toolbar, select "Customize" and alter the toolbar - you can add and remove buttons of your choosing, change whether they display a picture, text, or both, add a separator before the button, and all kinds of other stuff. The idea is that the user can customize the app to their liking. In a moment of boredom, I thought I'd see if I could introduce something similar in Tcl and Tk.

This is very much a work in progress, but it does seem to be working. I started it a couple of days ago, and I'm adding features whenever I get a moment. Currently, you can...

  • Add a button (though only programatically, at present)
  • Delete a button (just drag it off the toolbar while customizing, or selected Delete from the context menu)
  • Start "Customizing" by right-clicking the toolbar and selecting it. You can stop customizing in the same way
  • Select whether or not a button "begins a group", by adding a separator before it (from context menu)
  • Change how a button is displayed (toolbar's default style, text only, image only, or both, also from context menu)
  • Reset a button (to toolbar's default display style/default text/default icon). There's currently no way to alter the icon/text used, except from the console, so resetting doesn't do a lot.

The context menus are shown by right-clicking a button while you're customizing. As you drag a button, it's relief goes from solid to ridge, when you move it off the toolbar (to indicate it will be deleted).

It also includes basic balloon code, so that the buttons tell you what they are, when you move over them with the cursor. It could really use some custom cursors, so that when you drag a button off the toolbar, the cursor changes to tell you what's going to happen, but that's likely to be the last thing I ever get around to adding. Some more features I hope to add, over the coming days...

  • Ability to add buttons properly, by dragging them onto the toolbar
  • Ability to move buttons, by dragging them along the toolbar
  • Ability to alter buttons more - their name, icon, more...?
  • Probably more I haven't thought of, yet.

Even with the basic features it has so far, though, you can get an idea for how it's going to work. (And for anyone with MS Word installed, just open it up, right-click the toolbars, and select "Customize" - that's what I'm hoping to have, when I'm done :) Any comments, thoughts, or criticisms are highly appreciated.


The code:

 namespace eval ::toolbar {}

 array set ::toolbar::functions {

            0,icon ::img::new
            0,text "New Document"
            0,cmd  "do_new_document"

            1,icon ::img::open
            1,text "Open Document"
            1,cmd  "do_open_document"

            2,icon ::img::save
            2,text "Save Document"
            2,cmd  "do_save"

            3,icon ::img::save
            3,text "Save As..."
            3,cmd  "do_save_as"

            4,icon ::img::print
            4,text "Print"
            4,cmd  "do_print"

 };# array set ::toolbar::functions

 proc ::toolbar::startCustomize {tb} {

   bind ToolbarButton <Enter> break
   bind ToolbarButton <Leave> break
   bind ToolbarButton <ButtonPress-1> {::toolbar::select %W ; break}
   bind ToolbarButton <B1-Motion> {::toolbar::drag %W %X %Y; break} ;# to allow moving/deleting buttons by dragging
   bind ToolbarButton <ButtonRelease-1> {::toolbar::dragRelease %W %X %Y ; break} ;# as above
   bind ToolbarButton <Key-space> {::toolbar::select %W ; break}
   bind ToolbarButton <3> {::toolbar::select %W ; ::toolbar::showOptions %W %X %Y ; break}

   bind Toolbar <3> {::toolbar::showToolbarOptions %W %X %Y 1; break}

 };# tb / startCustomize

 proc ::toolbar::endCustomize {tb} {

   bind ToolbarButton <Enter> continue
   bind ToolbarButton <Leave> continue
   bind ToolbarButton <ButtonPress-1> continue
   bind ToolbarButton <ButtonRelease-1> continue
   bind ToolbarButton <Key-space> continue
   bind ToolbarButton <3> {::toolbar::showToolbarOptions [winfo parent %W] %X %Y 0; break}

   bind Toolbar <3> {::toolbar::showToolbarOptions %W %X %Y 0; break}

   if { [info exists ::toolbar::this($tb,selected)] && [winfo exists $::toolbar::this($tb,selected)] } {
        ::toolbar::deselect $tb

 };# tb / endCustomize

 proc ::toolbar::resetButton {btn} {
   variable functions

   set tb [winfo parent $btn]
   if { [winfo class $tb] != "Toolbar" } {

   upvar 0 ::toolbar::this local
   set func $local($tb,func,$btn)
   set local($tb,text,$btn) $functions($func,text)
   set local($tb,icon,$btn) $functions($func,icon)
   ::toolbar::setCompound $btn default

 };# ::toolbar::resetButton

 proc ::toolbar::drag {w x y} {

   set container [winfo containing $x $y]
   set tb [winfo parent $w]
   if { $container != $tb && ![string match "${tb}.*" $container] } {
        # it's being dragged off the toolbar
        $w configure -relief ridge
      } else {
        $w configure -relief solid

 };# tb / drag

 proc ::toolbar::dragRelease {w x y} {

   set container [winfo containing $x $y]
   set tb [winfo parent $w]
   if { $container != $tb && ![string match "${tb}.*" $container] } {
        # it's been dragged off the toolbar - delete it!
        ::toolbar::delete $w
   #abc check if it's been moved, and where it should go to

 };# tb / dragRelease

 proc ::toolbar::delete {w} {

   upvar 0 ::toolbar::this local
   set tb [winfo parent $w]
   set pos [lsearch -exact $local($tb,bar) $w]
   set local($tb,bar) [lreplace $local($tb,bar) $pos $pos]
   destroy $w
   catch {destroy $local($tb,beginWidget,$w)}
   array unset local $tb,*,$w)

 };# tb / delete

 proc ::toolbar::toggleBegin {w} {
   variable counter

   set tb [winfo parent $w]
   upvar 0 ::toolbar::this local
   if { [info exists local($tb,beginWidget,$w)] } {
        destroy $local($tb,beginWidget,$w)
        unset local($tb,beginWidget,$w)
        set local($tb,beginBool,$w) 0
      } else {
        set begin [frame $tb.[incr counter($tb)] -width 2 -borderwidth 1 -relief ridge -bg grey65]
        pack $begin -before $w -padx 5 -side left -pady 1 -fill y
        set local($tb,beginWidget,$w) $begin
        set local($tb,beginBool,$w) 1

 };# tb / toggleBegin

 proc ::toolbar::showToolbarOptions {tb x y customizing} {

   if { [winfo class $tb] != "Toolbar" } {

   #abc show right-click menu with "Customize" option to start customizing!
   set w .toolbarOptionsMenu
   catch {destroy $w}
   menu $w -tearoff 0
   if { $customizing } {
        $w add command -label "Stop Customizing" -underline 0 -command [list ::toolbar::endCustomize $tb]
      } else {
        $w add command -label "Customize..." -underline 0 -command [list ::toolbar::startCustomize $tb]
   $w post $x $y

 };# tb / showToolbarOptions

 proc ::toolbar::showOptions {btn x y} {

   if { [lsearch [bindtags $btn] "ToolbarButton"] < 0 } {

   #abc do stuff!

   set tb [winfo parent $btn]

   set w .toolbarButtonOptions
   catch {destroy $w}
   #toplevel $w
   #wm withdraw .
   #wm overrideredirect $w 1
   #wm title $w "Toolbar Customization"
   #bind $w <FocusOut> {if { [winfo toplevel %W] == %W } {destroy %W}}
   menu $w -tearoff 0
   $w add command -label "Reset" -underline 0 -command [list ::toolbar::resetButton $btn]
   $w add command -label "Delete" -underline 0 -command [list ::toolbar::delete $btn]
   $w add separator
   $w add checkbutton -label "Begin a group?" -variable ::toolbar::this($tb,beginBool,$btn) \
                      -command [list ::toolbar::toggleBegin $btn]
   $w add separator
   $w add radiobutton -label "Default Style" -variable ::toolbar::this($tb,compound,$btn) \
                      -value "default" -command [list ::toolbar::setCompound $btn var]
   $w add radiobutton -label "Text Only" -variable ::toolbar::this($tb,compound,$btn) \
                      -value "text" -command [list ::toolbar::setCompound $btn var]
   $w add radiobutton -label "Image Only" -variable ::toolbar::this($tb,compound,$btn) \
                      -value "image" -command [list ::toolbar::setCompound $btn var]
   $w add radiobutton -label "Image and Text" -variable ::toolbar::this($tb,compound,$btn) \
                      -value "both" -command [list ::toolbar::setCompound $btn var]

   $w post $x $y

   #wm geography $w $x $y
   #wm deiconify $w

 };# tb / showOptions

 proc ::toolbar::select {w} {

   set parent [winfo parent $w]
   ::toolbar::deselect $parent
   $w configure -border 2 -relief solid
   set ::toolbar::this($parent,selected) $w

 };# tb / select

 proc ::toolbar::deselect {tb} {

   upvar 0 ::toolbar::this local
   if { [info exists local($tb,selected)] && [winfo exists $local($tb,selected)] } {
        set w $local($tb,selected)
        $w configure -border $local($tb,border) -relief $local($tb,relief)
        set local($tb,selected) ""

 };# tb / deselect

 proc ::toolbar::toolbar {w args} {
   variable counter

   if { [winfo exists $w] } {
        set par [winfo parent $w]
        set len [string length $par]
        if { $len > 1 } {
             incr len
        set this [string range $w $len end]
        error "window name \"$this\" already exists in parent"

   set ::toolbar::this($w,relief) flat
   set ::toolbar::this($w,border) 2
   set ::toolbar::this($w,compound) image
   set ::toolbar::this($w,overrelief) raised

   set ::toolbar::this($w,bar) [list]

   set options [list]
   foreach {name value} $args {
         if { $name == "-buttonrelief" } {
              set ::toolbar::this($w,relief) $value
            } elseif { $name == "-buttonoverrelief" } {
              set ::toolbar::this($w,overrelief) $value
            } elseif { $name == "-buttonborder" } {
              set ::toolbar::this($w,border) $value
            } elseif { $name == "-buttoncompound" } {
              set ::toolbar::this($w,compound) $value
            } else {
              lappend options $name $value

   set counter($w) 0
   set frame [eval ::frame $w -class Toolbar $options -padx 3]
   bindtags $frame [linsert [bindtags $frame] 1 "Toolbar"]

   ::toolbar::endCustomize $frame ;# setup default bindings
   return $frame;

 };# tb / toolbar

 proc ::toolbar::button {tb func {pos "end"}} {
   variable functions
   variable this
   variable counter

   if { [winfo class $tb] != "Toolbar" } {
        error "window \"$tb\" is not a toolbar widget"

   if { ![info exists functions($func,cmd)] } {
        error "invalid toolbar function \"$func\""

   set button $tb.[incr counter($tb)]
   ::button $button -relief $this($tb,relief) -overrelief $this($tb,overrelief) -border $this($tb,border) \
                                  -command $functions($func,cmd)

   upvar 0 ::toolbar::this local
   #($tb,bar) bar
   set local($tb,bar) [linsert $local($tb,bar) $pos $button]
   set pos [lsearch -exact $local($tb,bar) $button]
   if { $pos == "0" } {
        pack $button -side left -padx 1 -pady 1 -anchor nw
      } else {
        pack $button -side left -padx 1 -pady 1 -anchor nw -after [lindex $local($tb,bar) [expr {$pos-1}]]
   bindtags $button [linsert [bindtags $button] 0 ToolbarButton]
   ::toolbar::balloon $button
   set local($tb,func,$button) $func
   set local($tb,text,$button) $functions($func,text)
   set local($tb,icon,$button) $functions($func,icon)
   set local($tb,beginBool,$button) 0

   ::toolbar::setCompound $button default
   return $button;

 };# tb / button

 proc ::toolbar::setCompound {w {compound default}} {

   upvar 0 ::toolbar::this local
   variable functions

   set tb [winfo parent $w]
   set func $local($tb,func,$w)

   if { $compound == "var" } {
        # use the var setting for this button
        set compound $local($tb,compound,$w)

   if { $compound != "text" && $compound != "image" && $compound != "both" && $compound != "default" } {
        set compound $local($tb,compound) ;# bad value, so we use the toolbar default

   if { $compound == "default" } {
        set compoundDisp "default"
        set compound $local($tb,compound)
      } else {
        set compoundDisp $compound

   if { $compound == "text" || $compound == "both" } {
        if { $local($tb,text,$w) == "" } {
             if { $functions($func,text) == "" && $compound == "text" } {
                  set text "Function $func"
                } else {
                  set text $functions($func,text)
           } else {
             set text $local($tb,text,$w)
       } else {
         set text ""

   set image "" ; set text ""
   if { $compound == "image" || $compound == "both" } {
        if { ![catch {image type $local($tb,icon,$w)}] } {
             # use button-specific image
             set image $local($tb,icon,$w)
           } elseif { ![catch {image type $functions($func,icon)}] } {
             # use function-specific image
             set image $functions($func,icon)
           } else {
             # fall back to just text
             set compound "text"
   if { $compound == "text" || $compound == "both" } {
        if { $local($tb,text,$w) != "" } {
             # use button-specific text
             set text $local($tb,text,$w)
           } elseif { $functions($func,text) != "" } {
             # use function-specific text
             set text $functions($func,text)
           } else {
             # if we're on compound == text (not both), use default text
             if { $compound == "text" } {
                  set text "Function $func"

   if { $image == "" || $text == "" } {
        set compound "none"
      } else {
        set compound "left"
        set text " $text" ;# add a single space before text, for a better appearance.
   $w configure -image $image -text $text -compound $compound
   set local($tb,compound,$w) $compoundDisp

 };# tb / setCompound

 proc ::toolbar::balloon {w} {
     bind $w <Any-Enter> "after 450 [list ::toolbar::balloonShow %W]"
     bind $w <Any-Leave> [list destroy %W.balloon]
 };# tb / balloon

 proc ::toolbar::balloonShow {w} {

   if { [eval winfo containing  [winfo pointerxy .]] != $w } {

   set tb [winfo parent $w]
   set text $::toolbar::this($tb,text,$w)

   set top $w.balloon
   catch {destroy $top}
   toplevel $top
   wm title $top $text
   $top configure -bd 1 -bg black
   wm overrideredirect $top 1
   pack [message $top.txt -aspect 10000 -bg lightyellow \
         -font {"" 8} -text $text -padx 1 -pady 0]
   bind $top <ButtonPress-1> {catch {destroy [winfo toplevel %W]}}
   set wmx [winfo pointerx $w]
   set wmy [expr [winfo rooty $w]+[winfo height $w]]
   if {[expr $wmy+([winfo reqheight $top.txt]*2)]>[winfo screenheight $top]} {
       incr wmy -[expr [winfo reqheight $top.txt]*2]
   if {[expr $wmx+([winfo reqwidth $top.txt]+5)]>[winfo screenwidth $top]} {
       incr wmx -[expr [winfo reqwidth $top.txt]*2]
       set wmx [expr [winfo screenwidth $top]-[winfo reqwidth $top.txt]-7]
   wm geometry $top \
      [winfo reqwidth $top.txt]x[winfo reqheight $top.txt]+$wmx+$wmy
   raise $top
 };# tb / balloonShow

 namespace eval ::img {}
 image create photo ::img::new -data {

 image create photo ::img::open -data {

 image create photo ::img::save -data {

 image create photo ::img::print -data {

 catch {console show}

 ###### TEST #######
 pack [set toolbar [toolbar::toolbar .tb]] -side top -fill x -anchor nw
 toolbar::button $toolbar 0
 toolbar::button $toolbar 1
 ::toolbar::toggleBegin [toolbar::button $toolbar 2]
 toolbar::button $toolbar 4

 pack [frame .btm] -side top -expand 1 -fill both
 pack [text .btm.txt -yscrollcommand ".btm.sb set" -wrap word] -side left -expand 1 -fill both
 pack [scrollbar .btm.sb -command ".btm.txt yview"] -side left -fill y

 catch {wm state . zoomed}

if 0 {

[Category Widget] | toolbar