if 0 { 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...
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 {}
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 ; break}
bind Toolbar <3> {continue}
};# 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> continue
bind Toolbar <3> {::toolbar::showToolbarOptions %W %X %Y ; break}
if { [info exists ::toolbar::this($tb,selected)] && [winfo exists $::toolbar::this($tb,selected)] } {
::toolbar::deselect $tb
}
};# tb / endCustomize
proc ::toolbar::drag {w x y} {
};# 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,begin,$w)}
unset -nocomplain local($tb,begin,$w)
};# tb / delete
proc ::toolbar::toggleBegin {w} {
variable counter
set tb [winfo parent $w]
upvar 0 ::toolbar::this local
if { [info exists local($tb,begin,$w)] } {
destroy $local($tb,begin,$w)
unset $local($tb,begin,$w)
} 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,begin,$w) $begin
}
};# tb / toggleBegin
proc ::toolbar::showToolbarOptions {tb x y} {
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
$w add command -label "Customize..." -underline 0 -command [list ::toolbar::startCustomize $tb]
$w post $x $y
};# tb / showToolbarOptions
proc ::toolbar::showOptions {w} {
if { [winfo class $w] != "ToolbarButton" } {
return;
}
#abc do stuff!
};# 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) none
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) \
-compound $this($tb,compound) -image $functions($func,icon) \
-text $functions($func,name) -command $functions($func,cmd)
upvar 0 ::toolbar::this($tb,bar) bar
set bar [linsert $bar $pos $button]
set pos [lsearch -exact $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 $bar [expr {$pos-1}]]
}
bindtags $button [linsert [bindtags $button] 0 ToolbarButton]
::toolbar::balloon $button $functions($func,name)
return $button;
};# tb / button
proc ::toolbar::balloon {w help} {
bind $w <Any-Enter> "after 450 [list ::toolbar::balloonShow %W [list $help]]"
bind $w <Any-Leave> [list destroy %W.balloon]
};# tb / balloon
proc ::toolbar::balloonShow {w text} {
if { [eval winfo containing [winfo pointerxy .]] != $w } {
return;
}
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
if 0 {
And a short "demo program". The buttons will all throw errors when clicked, so don't click them ;) Just right-click beside/between them and select "Customize", then drag 'em off the toolbar or click them to select them. That's about all you can do, so far, without going back to the Tcl prompt.
}
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==
}
array set ::toolbar::functions {
0,icon ::img::new
0,name "New Document"
0,cmd "do_new_document"
1,icon ::img::open
1,name "Open Document"
1,cmd "do_open_document"
2,icon ::img::save
2,name "Save Document"
2,cmd "do_save"
3,icon ::img::save
3,name "Save As..."
3,cmd "do_save_as"
4,icon ::img::print
4,name "Print"
4,cmd "do_print"
};# array set ::toolbar::functions
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 {
}