tk_optionCascade
Richard Suchenwirth 2006-12-22 - The tk_optionMenu offers a handy alternative to a combobox. But for a larger number of structured choices, it is sometimes better to have cascading menus instead of one. Here's a quick hack for that. It follows the same simple API as tk_optionMenu, but if an item is a list of more than one elements, it is turned into a submenu. (Add an extra layer of braces around labels that contain spaces - see example below.) Oh, and the special item "--" makes a separator.
proc tk_optionCascade {w varName args} {
set dn [image create bitmap -data "#define i_width 7\n\#define i_height 5
static char i_bits[] = {\n0,127,62,28,8\n}"]
set it [lindex $args 0]
while {[llength $it]>1} {set it [lindex $it 0]}
set ::$varName $it
menubutton $w -menu $w.m -text $it -relief raised \
-image $dn -compound right
menu $w.m -tearoff 0
tk_optionCascade_add $w.m $varName $args
trace add variable ::$varName write "$w config -text \${$varName} ;\#"
return $w.m
}
proc tk_optionCascade_add {w varName argl} {
set n 0
set colbreak 0
foreach arg $argl {
if {$arg eq "--"} {
$w add separator
} elseif {$arg eq "|"} {
set colbreak 1; continue
} elseif {[llength $arg] == 1} {
$w add radiobutton -label [join $arg] -variable $varName
} else {
set child [menu $w.[incr n] -tearoff 0]
$w add cascade -label [lindex $arg 0] -menu $child
tk_optionCascade_add $child $varName [lrange $arg 1 end]
}
if $colbreak {
$w entryconfigure end -columnbreak 1
set colbreak 0
}
}
}
# Demo and testing:
package require Tk
tk_optionCascade .o myvar \
{color red green blue -- {other yellow magenta cyan}} \
{hue dark medium light} \
-- {"multi word example"} ok
pack .oRS 2007-02-05: added "|" to be treated as column-break, for data-driven multicolumn menus, such that e.g.
tk_optionCascade .x myvar northwest southwest | northeast southeast
shows a menu of two columns, with directions in the plausible place :)
Teo 2008-04-13: A fairly common case when tk_optionMenu fails to work properly is a big list of unstructured items (e.g. a list of font families). The following tk_optionCascade2 adds cascading menus for items which don't fit the screen height.
proc tk_optionCascade2 {path varName value args} {
upvar #0 $varName v
if {![info exists v]} {
set v $value
}
set m [tk_optionMenu $path $varName $v]
tk_optionCascade2_menu $m $varName [linsert $args 0 $value]
return $m
}
proc tk_optionCascade2_menu {m varName argl} {
$m delete 0 end
set next [menu $m.n -tearoff 0]
$m add cascade -label "More" -menu $next
set index 0
set len [llength $argl]
set height [winfo screenheight $m]
foreach arg $argl {
$m insert $index radiobutton -label $arg -variable $varName
incr index
update idletasks
if {[winfo reqheight $m] > $height && $index < $len} {
incr index -1
$m delete $index
tk_optionCascade2_menu $next $varName [lrange $argl $index end]
return
}
}
$m delete end
}
# demo
eval tk_optionCascade2 .q1 myvar2 [lsort [font families]]
pack .q1aplsimple - 2020-04-27 17:44:46
Below is a bit modified tk_optionCascade widget providing three options for customizing:
- ttk::menubutton options (e.g. -width: if positive, sets a fixed size of widget)
- a command to get options of entries dynamically
- additional "static" options of entries
Also, this version of tk_optionCascade amends few things:
- Using a full qualified name of variable, thus fixing troubles with nested namespaces, e.g. in the following case:
namespace eval t { variable myvar "red"
namespace eval t { variable myvar "blue" }
puts "t::myvar = $t::myvar"
...
tk_optionCascade .o t::myvar $items \
...
}- Removing -image option, due to ttk::style theme.
- Hiding options with a second click on the menu button, due to ttk::menubutton.
Please:
proc tk_optionCascade {w vname items {mbopts ""} {precom ""} args} {
# A bit modified tk_optionCascade widget made by Richard Suchenwirth.
# w - widget name
# vname - variable name for current selection
# items - list of items
# mbopts - ttk::menubutton options (e.g. "-width -4")
# precom - command to get entry's options (%a presents its label)
# args - additional options of entries
# See also:
# https://wiki.tcl-lang.org/page/tk_optionCascade
set it [lindex $items 0]
while {[llength $it]>1} {set it [lindex $it 0]}
set $vname $it
ttk::menubutton $w -menu $w.m -text $it {*}$mbopts
menu $w.m -tearoff 0
tk_optionCascade_add $w.m $vname $items $precom {*}$args
trace add variable $vname write "$w config -text \${$vname} ;\#"
return $w.m
}
proc tk_optionCascade_add {w vname argl precom args} {
set n [set colbreak 0]
foreach arg $argl {
if {$arg eq "--"} {
$w add separator
} elseif {$arg eq "|"} {
if {[tk windowingsystem] ne "aqua"} { set colbreak 1 }
continue
} elseif {[llength $arg] == 1} {
set label [join $arg]
if {$precom eq ""} {
set adds ""
} else {
set adds [eval [string map [list %a $label] $precom]]
}
$w add radiobutton -label $label -variable $vname {*}$args {*}$adds
} else {
set child [menu $w.[incr n] -tearoff 0]
$w add cascade -label [lindex $arg 0] -menu $child
tk_optionCascade_add $child $vname [lrange $arg 1 end] $precom {*}$args
}
if $colbreak {
$w entryconfigure end -columnbreak 1
set colbreak 0
}
}
return
}
# Demo and testing:
package require Tk
ttk::style theme use clam
set items [list {color red green blue -- {colored yellow magenta cyan
| #52CB2F #FFA500 #CB2F6A | #FFC0CB #90EE90 #8B6914}} \
{hue dark medium light} -- {{multi word example}} ok]
set comm { if {"%a" in {yellow magenta cyan} || ![string first "#" "%a"]} \
{set _ "-background %a -activeforeground %a"} else {set _ ""} }
tk_optionCascade .o ::myvar $items "-width -4" $comm \
-command {puts "::myvar = $::myvar"}
pack .o
A screenshot of this test:
