Version 1 of ComboBox megawidget with adjusted width

Updated 2017-09-20 15:23:29 by bll

Combobox megawidget with adjusted width

bll 2017-9-20 This widget will automatically adjust the width of the combobox to match the values supplied. Good for localized test.

It has an internal cache, as in my particular use case, I have certain screens that display the same combobox multiple times. This can be turned off or removed.

The -popdownfont argument is an addition and can be used to set the popdown listbox's font. The code is set up to do this once the popdown listbox is mapped. (If the popdown listbox is force-created early, it may display in the entirely wrong place on the screen).

#!/usr/bin/tclsh
#
# Copyright 2017 Brad Lanam Walnut Creek CA
#

package require Tcl 8.5-
package require Tk

# cboxadj is a width-adjusted combobox
#   -popdownfont : will set the font for the popdown listbox.
proc ::cboxadj { nm args } {
  cboxadjust new $nm {*}$args
  return $nm
}

namespace eval cboxadj {
  variable vars

  proc handler { cbox args } {
    $cbox {*}$args
  }

  proc setpopdownfont { w } {
    variable vars

    if { $w in $vars(bindlist) } {
      $w configure -font [dict get $vars(fontlist) $w]
    }
  }

  proc bindpopdown { wprefix font } {
    variable vars

    if { ! $vars(bound) } {
      bind ComboboxListbox <Map> \
          +[list ::cboxadj::setpopdownfont %W]
      set vars(bound) true
    }
    lappend vars(bindlist) $wprefix.popdown.f.l
    dict set vars(fontlist) $wprefix.popdown.f.l $font
  }

  proc init { } {
    variable vars

    set vars(bound) false
    set vars(bindlist) [list]
    set vars(fontlist) [dict create]
  }

  init
}

::oo::class create cboxadjust {
  constructor { nm args } {
    my variable vars

    set vars(usecache) true

    set vars(widget) [ttk::combobox ${nm}]
    set vars(cbox) ${nm}_cboxadj
    rename $vars(widget) ::$vars(cbox)
    interp alias {} $vars(widget) {} ::cboxadj::handler [self]
    uplevel 2 [list $vars(widget) configure {*}$args]

    set bt [bindtags $vars(widget)]
    bindtags $vars(widget) [concat {*}$bt cboxadjbt]
    bind cboxadjbt <space> { ttk::combobox::Post %W }
    bind $vars(widget) <Destroy> [list [self] destruct]

    set wid [my _getWidth $vars(cbox)]
    $vars(cbox) configure -width $wid
  }

  method destruct { } {
    my variable vars
    interp alias {} $vars(widget) {}
    [self] destroy
  }

  method _getWidth { nm } {
    my variable vars

    set values [$nm cget -values]
    set found false
    if { $vars(usecache) } {
      set svalues [join $values {}]
      if { [info exists vars(cboxadj.cache.$svalues)] } {
        set found true
        set wid $vars(cboxadj.cache.$svalues)
      }
    }
    if { ! $found } {
      set pwid 0
      set font [$nm cget -font]
      foreach {val} $values {
        set pwid [expr {max($pwid,[font measure $font $val])}]
      }
      set wid [expr {round($pwid / [font measure $font 0])}]
      # the wider the combobox is, the greater chance of error...
      set wid [expr {$wid + int($wid / 10) + 2}]
      if { $vars(usecache) } {
        set vars(cboxadj.cache.$svalues) $wid
      }
    }
    return $wid
  }

  method unknown { args } {
    my variable vars

    set nm $vars(cbox)
    return [uplevel 2 [list $nm {*}$args]]
  }

  method configure { args } {
    my variable vars

    foreach {k v} $args {
      if { $k eq "-popdownfont" } {
        set vars($k) $v
        ::cboxadj::bindpopdown $vars(widget) $v
      } elseif { $k eq "-values" } {
        uplevel 2 [list $vars(cbox) configure $k $v]
        set wid [my _getWidth $vars(cbox)]
        $vars(cbox) configure -width $wid
      } else {
        uplevel 2 [list $vars(cbox) configure $k $v]
      }
    }
    return -code ok
  }
}

package provide cboxadj 1.0
Category Widgetmegawidget