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