Updated 2003-08-31 18:17:00

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:

  • the arrow buttons affect a menubutton widget full of radiobutton entries, rather than an entry widget
  • the menubutton can still be used for input
  • arrows are shown by use of unicode characters rather than drawing a shape or using bitmaps
  • font and color attributes are passed through the routine to the underlying widgets
  • a -cycle flag can be used to come back to the top of the list when hitting the last entry (and vice-versa)
  • if the widget is not in -cycle mode, then an up/down arrow is disabled when at one or the other limit of the list, whether the list edge was reached via up/down buttons, or invoking the menubutton directly
  • a -numeric flag can be used to reverse the action of the arrows--in a typical list of say... names... you would want the up/down arrows to move up/down through menu entries, but in a numeric list, you probably want the entries to have the lowest number at the top of the menu, highest at the bottom, but have the up arrow go to a higher numeric value (therefore down the list)
  • there is automatic repeating functionality on the up/down buttons (if they are held down)
  • the user must supply the name of a global variable that will be 'bound' to the menubutton after the -variable flag
  • the user must supply a list of values to place in the menu after the -values flag
  • if the variable is set before creating a widget, its contents will be the initial value of the menubutton

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

31 Aug 2003 Mike Tuxford: Nice and works well but why is there no author credit? Interesting switch structure too.

Category GUI | Category Widget