- 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.
- 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.
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}