I've been playing with the code in the spinbox wiki for some time. The code below is compatible with versions of tcl/tk before 8.4 and has the following features:
enjoy
#!/usr/bin/wish
proc spin_mb {args} {
set w [lindex $args 0]
set cycle "-nocycle"
array set buttoncmd {up listprev dn listnext}
array set buttonsym "up \u25b2 dn \u25bc"
array set passthrough {}
# process flags
for { set i 1 } { $i < [llength $args] } { incr i } {
set flag [ lindex $args $i ]
switch -glob -- $flag {
{-cycle} {
set cycle "-cycle"
}
{-variable} {
incr i
set var [ lindex $args $i ]
}
{-values} {
incr i
set values [ lindex $args $i ]
}
{-numeric} {
# with a numeric list, we probably want the numbers to list
# smallest at top, but the down arrow should take us to a
# numerically smaller number...which means the down arrow moves
# up, visually, through the list
array set buttoncmd {up listnext dn listprev}
}
{-font}
-
{-bg}
-
{-fg}
-
{-*background}
-
{-*foreground}
-
{-*color} {
# pass through color and font values to the sub-widgets
set nextarg [ lindex $args [ expr $i + 1 ] ]
if { ($nextarg != "") && ([string index $nextarg 0] != "-") } {
set passthrough([lindex $args $i]) $nextarg
incr i
}
}
}
}
# check that we have all info we need to actually function
if { (![info exists var]) || (![info exists values]) } {
error " " "spin_mb needs -variable <global var> and -values <values>"
}
set fullvarname $var
if { [string range $var 0 1] != "::"} {
set fullvarname "::$var"
}
# if initial value in $var isn't in list, set it to 1st list element
if {(![info exists $fullvarname])} {
set $fullvarname [ lindex $values 0 ]
}
if { [ lsearch -exact $values [ set $fullvarname ] ] == -1 } {
set $fullvarname [ lindex $values 0 ]
}
frame $w -relief groove
menubutton $w.menubutton -menu $w.menubutton.menu -textvariable $var -relief raised
menu $w.menubutton.menu
set maxlen 0
foreach item $values {
$w.menubutton.menu add radiobutton -label $item -variable $var -command "ghostarrows $cycle $w $fullvarname"
if { [string length $item] > $maxlen } {
set maxlen [ string length $item ]
}
}
$w.menubutton configure -width $maxlen
namespace eval ::spmb_vals {}
set ::spmb_vals$fullvarname $values
foreach i {up dn} {
set arr $w.$i
button $arr -padx 0 -pady 0 -text $buttonsym($i) -command "$buttoncmd($i) $cycle $fullvarname $w" -font {Times 6}
# add repeating fuctionality to arrow button... more code based on wiki
proc repeat$arr {arr pause} {
if {![set ::ok_$arr]} {
return
}
$arr config -relief sunken
uplevel eval [$arr cget -command]
after $pause "repeat$arr $arr 100"
}
bind $arr <ButtonPress-1> {set ::ok_%W 1; repeat%W %W 1000}
bind $arr <ButtonRelease-1> "set ::ok_%W 0; $arr config -relief raised"
#bind $arr <Leave> "set ::ok_%W 0; [ bind Button <Leave> ]"
bind $arr <Leave> [ bind Button <Leave> ]
bind $arr <Enter> [ bind Button <Enter> ]
bindtags $arr [lreplace [bindtags $arr] 1 1 ]
}
# use color and font passthroughs
foreach i [array names passthrough] {
foreach j {menubutton menubutton.menu up dn} {
$w.$j configure $i $passthrough($i)
}
if { ($i == "-bg")||($i == "-background") } {
# apply bg color to frame and trough around arrowbuttons
$w configure $i $passthrough($i)
$w.dn configure -highlightbackground $passthrough($i)
$w.up configure -highlightbackground $passthrough($i)
} elseif { $i == "-font" } {
# int(font*2/3) applied to arrowbuttons
set fontsize [ lindex $passthrough($i) 1 ]
if { $fontsize != "" } {
set arrowfont [ lreplace $passthrough($i) 1 1 [ expr int ( $fontsize / 2 ) ] ]
$w.up configure -font $arrowfont
$w.dn configure -font $arrowfont
}
}
}
pack $w.menubutton -side left -fill y
pack $w.up -anchor n -ipady 0 -ipadx 0 -pady 0
pack $w.dn -anchor s -ipady 0 -ipadx 0 -pady 0
ghostarrows $cycle $w $fullvarname
}
# return the next element in a list
proc listprev {cycle var w} {
upvar $var currval
set fullist [set ::spmb_vals$var]
set element_pos [lsearch -exact $fullist $currval]
set listlen [ expr [ llength $fullist ] - 1 ]
if { $element_pos > 0 } {
set currval [ lindex $fullist [incr element_pos -1] ]
} elseif { $cycle == "-cycle" } {
set currval [ lindex $fullist $listlen ]
}
ghostarrows $cycle $w $var
}
# return the next element in a list
proc listnext {cycle var w} {
upvar $var currval
set fullist [set ::spmb_vals$var]
set listlen [ expr [ llength $fullist ] - 1 ]
set element_pos [lsearch -exact $fullist $currval]
if { $element_pos < $listlen } {
set currval [ lindex $fullist [incr element_pos] ]
} elseif { $cycle == "-cycle" } {
set currval [ lindex $fullist 0 ]
}
ghostarrows $cycle $w $var
}
# (de)activate arrowbuttons, based on location in list of data
proc ghostarrows {cycle w var} {
upvar $var currval
set fullist [set ::spmb_vals$var]
set listlen [ expr [ llength $fullist ] - 1 ]
set element_pos [lsearch -exact $fullist $currval]
if {$cycle == "-cycle"} {
return
}
if {$element_pos == 0 } {
$w.dn configure -state disabled
} else {
$w.dn configure -state normal
}
if {$element_pos == $listlen } {
$w.up configure -state disabled
} else {
$w.up configure -state normal
}
}
set blah "3"
spin_mb .test -cycle -fg green -bg black -variable bleh -values {joe fred bill henry}
spin_mb .test2 -numeric -font {Times 24 bold} -variable blah -values {1 2 3 4 5 6 7 8}
pack .test .test231 Aug 2003 Mike Tuxford: Nice and works well but why is there no author credit? Interesting switch structure too.