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.

Mike

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" } {
        return;
      }

   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
        return;
      }
   #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" } {
        return;
      }

   #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 } {
        return;
      }

   #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 } {
        return;
      }

   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 {
    R0lGODlhEAAQAIUAAPwCBFxaXNze3Ly2rJyanPz+/Ozq7GxqbPz6/GxubNTK
    xDQyNIyKhHRydERCROTi3PT29Pz29Pzy7PTq3My2pPzu5PTi1NS+rPTq5PTe
    zMyynPTm1Pz69OzWvMyqjPTu5PTm3OzOtOzGrMSehNTCtNS+tAAAAAAAAAAA
    AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAQABAAAAZ/
    QAAgQCwWhUhhQMBkDgKEQFIpKFgLhgMiOl1eC4iEYrtIer+MxsFRRgYe3wLk
    MWC0qXE5/T6sfiMSExR8Z1YRFRMWF4RwYIcYFhkahH6AGBuRk2YCCBwSFZgd
    HR6UgB8gkR0hpJsSGCAZoiEiI4QKtyQlFBQeHrVmC8HCw21+QQAh/mhDcmVh
    dGVkIGJ5IEJNUFRvR0lGIFBybyB2ZXJzaW9uIDIuNQ0KqSBEZXZlbENvciAx
    OTk3LDE5OTguIEFsbCByaWdodHMgcmVzZXJ2ZWQuDQpodHRwOi8vd3d3LmRl
    dmVsY29yLmNvbQA7
 }

 image create photo ::img::open -data {
    R0lGODlhEAAQAIUAAPwCBAQCBOSmZPzSnPzChPzGhPyuZEwyHExOTFROTFxa
    VFRSTMSGTPT29Ozu7Nze3NTS1MzKzMTGxLy6vLS2tLSytDQyNOTm5OTi5Ly+
    vKyqrKSmpIyOjLR+RNTW1MzOzJyenGxqZBweHKSinJSWlExKTMTCxKyurGxu
    bBQSFAwKDJyanERCRERGRAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAQABAAAAaR
    QIBwGCgGhkhkEWA8HpNPojFJFU6ryitTiw0IBgRBkxsYFAiGtDodDZwPCERC
    EV8sEk0CI9FoOB4BEBESExQVFgEEBw8PFxcYEBIZGhscCEwdCxAPGA8eHxkU
    GyAhIkwHEREQqxEZExUjJCVWCBAZJhEmGRUnoygpQioZGxsnxsQrHByzQiJx
    z3EsLSwWpkJ+QQAh/mhDcmVhdGVkIGJ5IEJNUFRvR0lGIFBybyB2ZXJzaW9u
    IDIuNQ0KqSBEZXZlbENvciAxOTk3LDE5OTguIEFsbCByaWdodHMgcmVzZXJ2
    ZWQuDQpodHRwOi8vd3d3LmRldmVsY29yLmNvbQA7
 }

 image create photo ::img::save -data {
    R0lGODlhEAAQAIUAAPwCBAQCBFRSVMTCxKyurPz+/JSWlFRWVJyenKSipJSS
    lOzu7ISChISGhIyOjHR2dJyanIyKjHx6fMzOzGRiZAQGBFxeXGRmZHRydGxq
    bAwODOTm5ExOTERGRExKTHx+fGxubNza3Dw+PDQ2NAAAAAAAAAAAAAAAAAAA
    AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAQABAAAAaA
    QIAQECgOj0jBgFAoBpBHpaFAbRqRh0F1a30ClAhuNZHwZhViqgFhJizSjIZX
    QCAoHOKHYw5xRBiAElQTFAoVQgINFBYXGBkZFxYHGRqIDBQbmRwdHgKeH2Yg
    HpmkIR0HAhFeTqSZIhwCFIdIrBsjAgcPXlBERZ4Gu7xCRZVDfkEAIf5oQ3Jl
    YXRlZCBieSBCTVBUb0dJRiBQcm8gdmVyc2lvbiAyLjUNCqkgRGV2ZWxDb3Ig
    MTk5NywxOTk4LiBBbGwgcmlnaHRzIHJlc2VydmVkLg0KaHR0cDovL3d3dy5k
    ZXZlbGNvci5jb20AOw==
 }

 image create photo ::img::print -data {
    R0lGODlhEAAQAIUAAPwCBFRKNAQCBPz+/MTCxExKLPTq5Pz29Pz6/OzezPT2
    9PTu7PTy7NzClOzm1PTu5LSabJyanPTm3FxaXOzCjOTKrOzi1OzaxOTSvJye
    nGRmZLyyTKSipDQyNERCROTi5Hx+fMzKzJSSlIyOjISChLS2tAT+BDw6PAAA
    AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAQABAAAAaY
    QIBwKAwIBMTkMDAYEApIpVBgOCAOg4RRGlAoEAuGIdGITgWOq4LxcCQgZkEk
    IHksHgYJOR6ZQCgVFhYJFxgTBVMZihoCfxUYDWUbUBGKGREcjBoQEB2TAB4C
    Ax+Vl5WMhyACHiEhH6IfIiMktCQgE0cZJQStr6O2t6EARxO6vK6iEx4dZsMC
    xbsmBB4nzUTEutVSSUdmfkEAIf5oQ3JlYXRlZCBieSBCTVBUb0dJRiBQcm8g
    dmVyc2lvbiAyLjUNCqkgRGV2ZWxDb3IgMTk5NywxOTk4LiBBbGwgcmlnaHRz
    IHJlc2VydmVkLg0KaHR0cDovL3d3dy5kZXZlbGNvci5jb20AOw==
 }

 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

}