Scaled checkbutton

Current Version: 1.2

bll 2018-8-16: This version is much simpler. It does not attempt to match the styling that the various available styles use. State handling is minimal

There are 7 different indicator styles.

If you know of other unicode character pairs that will work as indicators, let me know.

Note that some fonts may have different sizes of characters, which may cause your text to shift when the checkbutton is pressed. Try a different display pair, or try a different font. I found that 'Liberation Sans' did not work that well, and 'DejaVu Sans' is much better.

Unfortunately, the Windows standard font, Arial (and Tk seems to use 'Segoe UI') do not have good unicode characters. So, far, Droid Sans, Lucida Sans Unicode, Segoe UI Symbol seem to be ok. 'Segoe UI Symbol' seems like a good choice. Available since Windows 7. Haven't found a great choice for XP or Vista.

See also: Scaled Radiobutton

img-scheckbutton

Code

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

package require Tk

proc scheckbutton { nm args } {
  scbwidget new $nm {*}$args
  return $nm
}

namespace eval ::scbcmd {
  variable vars

  proc handler { w args } {
    $w {*}$args
  }

  proc initializeAll { } {
    variable vars

    if { [info exists ::scbcmd::initialized] } {
      return
    }
    set ::scbcmd::initialized true

    set tbg [ttk::style lookup TFrame -background]
    if { $::tcl_platform(os) eq "Darwin" } {
      # this isn't going to work...
      set tbg #ececec
    }
    lassign [winfo rgb . $tbg] bg_r bg_g bg_b
    set bg [format {#%02x%02x%02x} \
        [expr {$bg_r / 256}] \
        [expr {$bg_g / 256}] \
        [expr {$bg_b / 256}]]

    ttk::style configure SCheckbutton.TFrame \
        -background $bg
    ttk::style configure SCheckbutton.TLabel \
        -anchor e \
        -width {} \
        -background $bg \
        -highlightthickness 0
    ttk::style configure Indicator.SCheckbutton.TLabel \
        -anchor {}
  }
}

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

    ::scbcmd::initializeAll

    #
    set vars(ind.styles) {
        1 {chars {\u2610 \u2611} padding {0 0 0 0}}
        2 {chars {\u2610 \u2612} padding {0 0 0 0}}
        3 {chars {\u25ab \u25aa} padding {0 0 0 3}}
        4 {chars {\u25a1 \u25a0} padding {0 0 0 3}}
        5 {chars {\u25a1 \u25a3} padding {0 0 0 4}}
        6 {chars {\u25fb \u25fc} padding {0 0 0 3}}
        7 {chars {\u25fd \u25fe} padding {0 0 0 3}}
        }
    set vars(max.style) 7
    set vars(char.off) \u2610
    set vars(char.on) \u2611
    set vars(char.disp) $vars(char.off)
    set vars(-indicatorstyle) 1
    set vars(-indicatorcolor) {}
    set vars(-onvalue) 1
    set vars(-offvalue) 0
    set vars(currvalue) 0
    set vars(currstate) {}
    set vars(curr.value.state) off
    set vars(-command) {}
    set vars(font.basesize) 11

    # some defaults

    set vars(frame.cont) [ttk::frame $nm \
        -class Scaled.checkbutton \
        -style SCheckbutton.TFrame \
        ]
    set vars(widget) [ttk::label $nm.indicator \
        -style Indicator.SCheckbutton.TLabel \
        -textvariable [self]::vars(char.disp) \
        ]
    $vars(widget) configure -style 1.Indicator.SCheckbutton.TLabel
    set vars(label) [ttk::label ${nm}.label \
        -style SCheckbutton.TLabel \
        ]
    set vars(scb) ${nm}_scb
    rename $vars(frame.cont) ::$vars(scb)
    interp alias {} $vars(frame.cont) {} ::scbcmd::handler [self]
    uplevel 2 [list $vars(frame.cont) configure {*}$args]

    set vars(bind.tag) scbbt$vars(widget)
    bindtags $vars(widget) [concat [bindtags $vars(widget)] $vars(bind.tag)]

    grid $vars(widget) $vars(label) -in $vars(frame.cont) \
        -sticky {} -padx 0 -pady 0
    grid configure $vars(label) -sticky e
    grid configure $vars(label) -ipadx 1p

    # make sure any binds on the main hull get propagated to the display widget
    set bt [bindtags $vars(widget)]
    bindtags $vars(widget) [list $nm {*}$bt]

    bind $vars(widget) <Destroy> [list [self] destruct]

    bind $vars(widget) <ButtonRelease-1> +[list [self] setvalue]
    bind $vars(label) <ButtonRelease-1> +[list [self] setvalue]
    my adjustpadding
  }

  method adjustpadding { } {
    my variable vars

    set style [$vars(label) cget -style]
    set font [$vars(label) cget -font]
    if { $font eq {} } { set font TkDefaulFont }

    dict for {key info} $vars(ind.styles) {
      set opad [dict get $info padding]
      set sz [font metrics $font -ascent]
      set adj [expr {double($sz)/$vars(font.basesize)}]
      set npad [list]
      foreach {p} $opad {
        set np [expr {round(double($p)*$adj)}]
        lappend npad $np
      }

      ttk::style configure $key.Indicator.$style -padding $npad
      if { $vars(-indicatorcolor) ne {} } {
        set discolor [ttk::style lookup $style -foreground disabled #a3a3a3]
        ttk::style configure $key.Indicator.$style \
            -foreground $vars(-indicatorcolor)
        ttk::style map $key.Indicator.$style \
            -foreground [list disabled $discolor readonly $discolor]
      }
    }
  }

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

  method setvalue { } {
    my variable vars

    if { [$vars(widget) instate readonly] } {
      return
    }
    if { [$vars(widget) instate disabled] } {
      return
    }

    if { $vars(curr.value.state) } {
      set vars(curr.value.state) off
    } else {
      set vars(curr.value.state) on
    }
    set k -variable
    if { [info exists vars($k)] && [info exists $vars($k)] } {
      if { $vars(curr.value.state) } {
        set $vars($k) $vars(-onvalue)
      } else {
        set $vars($k) $vars(-offvalue)
      }
    }
    my checkvalue
    if { $vars(-command) ne {} } {
      {*}$vars(-command)
    }
  }

  method checkvalue { args } {
    my variable vars

    set k -variable
    if { [info exists vars($k)] && [info exists $vars($k)] } {
      if { [set $vars($k)] eq $vars(-onvalue) } {
        set vars(curr.value.state) on
      } else {
        set vars(curr.value.state) off
      }
    }
    if { $vars(curr.value.state) } {
      set vars(char.disp) $vars(char.on);
    } else {
      set vars(char.disp) $vars(char.off);
    }
  }

  method starttrace { } {
    my variable vars

    set k -variable
    if { [info exists vars($k)] && [info exists $vars($k)] } {
      trace add variable $vars($k) write [list [self] checkvalue]
    }
  }

  method unknown { args } {
    my variable vars

    if { [lindex $args 0] eq "instate" && [llength $args] == 2 } {
      return [uplevel 2 [list $vars(widget) {*}$args]]
    }
    if { [lindex $args 0] eq "state" && [llength $args] == 2 } {
      uplevel 2 [list $vars(label) {*}$args]
      return [uplevel 2 [list $vars(widget) {*}$args]]
    }
    return [uplevel 2 [list $vars(label) {*}$args]]
  }

  method cget { key } {
    my variable vars

    set rv {}
    if { $key eq "-variable" ||
        $key eq "-indicatorcolor" ||
        $key eq "-indicatorstyle" ||
        $key eq "-command" ||
        $key eq "-onvalue" ||
        $key eq "-offvalue" } {
      set rv $vars($key)
    } else {
      set rv [$vars(label) cget $key]
    }
    return $rv
  }

  method configure { args } {
    my variable vars

    foreach {key val} $args {
      if { $key eq "-indicatorstyle" } {
        if { ! [string is entier $val] || $val < 1 || $val > $vars(max.style) } {
          return
        }
        set vars(-indicatorstyle) $val
        lassign [dict get $vars(ind.styles) $val chars] \
            vars(char.off) vars(char.on)
        set style [$vars(label) cget -style]
        $vars(widget) configure -style $val.Indicator.$style
        set vars($key) $val
      } elseif { $key eq "-command" ||
          $key eq "-onvalue" ||
          $key eq "-offvalue" ||
          $key eq "-indicatorcolor" } {
        set vars($key) $val
      } elseif { $key eq "-variable" } {
        set fqv {}
        if { [string match {::*} $val] } {
          set fqv $val
        }
        if { $fqv eq {} } {
          set fqv [uplevel 2 [list namespace which -variable $val]]
          if { $fqv eq {} } {
            set ns [uplevel 2 [list namespace current]]
            set fqv $ns$val
            if { [string match ::::* $fqv] } {
              set fqv [string range $fqv 2 end]
            }
          }
        }
        set vars($key) $fqv
        if { ! [info exists $vars($key)] } {
          set $vars($key) {}
        }
        my starttrace
      } elseif { $key eq "-style" } {
        $vars(label) configure -style $val
        $vars(widget) configure -style $vars(-indicatorstyle).Indicator.$val
      } else {
        uplevel 2 [list $vars(label) configure $key $val]
      }
    }
    my checkvalue
    my adjustpadding
    return -code ok
  }
}

package provide scheckbutton 1.2

Demo Code

package require Tk
source code/scheckbutton.tcl

proc p { x } {
  puts "cmd: $x"
}

font create eee
font configure eee -size 28

set ::x 0
set ::y 1
foreach {st} [list 1 2 3 4 5 6 7] {
  scheckbutton .sa$st -variable ::x -text AAAA \
    -indicatorstyle $st -command [list p e]
  scheckbutton .sb$st -variable ::y -text BBBB \
    -indicatorstyle $st -command [list p f]
  grid .sa$st .sb$st
}

set st 5
ttk::style configure B.SCheckbutton.TLabel -font eee
scheckbutton .s1z -variable ::z -text EE\
    -indicatorstyle $st -command [list p e] -style B.SCheckbutton.TLabel
scheckbutton .s2z -variable ::z2 -text FF \
    -indicatorstyle $st -command [list p f] -style B.SCheckbutton.TLabel
set ::z 0
set ::z2 1
grid .s1z .s2z

set st 5
font create fff
font configure fff -size 13
ttk::style configure C.SCheckbutton.TLabel -font fff
scheckbutton .s1w -variable ::z -text EE\
    -indicatorstyle $st -command [list p e] -indicatorcolor blue \
    -style C.SCheckbutton.TLabel
scheckbutton .s2w -variable ::z2 -text FF \
    -indicatorstyle $st -command [list p f] -indicatorcolor blue \
    -style C.SCheckbutton.TLabel
grid .s1w .s2w

Category Widget