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

I will be dropping support for the 'checkButtonScaled' version below, and it will be
removed from this page at a later date.

[img-scheckbutton]

<<discussion>>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
======
<<enddiscussion>>
<<discussion>>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
======
<<enddiscussion>>

----

** checkButtonScaled **

'''Current Version: 1.22'''

[bll] 2016-05-10:  The standard [ttk::checkbutton] does not scale well for 4K displays.
This code is a pure tcl implementation of checkbuttons with no graphics.
It includes styling for all 30 themes.  I have attempted to match each
theme's styling reasonably well.  The package will change themes on a <<ThemeChanged>> event.

Place the package require in your code after tk scaling has been set.

Download from:

  https://gentoo.com/tcl/checkButtonScaled.tcl%|%https://gentoo.com/tcl/checkButtonScaled.tcl%|%

'''Version 1.22''' 2018-7-29
    * Add support for scid* and equilux themes.
    * Cleaned up and fixed all themes.
    * Minor fixes.

<<discussion>>Change Log

'''Version 1.21 ''' 2018-4-23
    * Add support for Mac OS X graphite color theme.

'''Version 1.20 ''' 2018-1-22
    * Remove bad code on trace unset.


'''Version 1.19 ''' 2018-1-6
    * Fixed scaling/display problems with the checkmarks.

'''Version 1.18 ''' 2017-9-14
    * Fixed issues with 'default' (et.al.) themes.

'''Version 1.17 ''' 2017-8-19
    * Changed to scale with the size of the configured font.  Since the font should be scaled up properly by tk scaling, this should work out ok.

'''Version 1.16 ''' 2016-8-16
    * Removed propagateBinds routine.  Binds placed on the main container are now executed properly.
    * Fixed focus state reporting.

'''Version 1.14 ''' 2016-7-4
    * Change spacer to be a frame
    * Better handle Mac OS X's crazy amount of extra label padding (fixed in 8.6.6).

'''Version 1.13 ''' 2016-7-2
    * Fixed focus issues.
    * Fixed highlight issues.
    * Fixed space bar toggle for tab-in.

'''Version 1.12 ''' 2016-6-14
    * keep disabled background color the same as the background color.

'''Version 1.11 ''' 2016-6-9
    * fixed trace on configure of same variable name.

'''Version 1.10 ''' 2016-6-3
    * improved efficiency
    * added changeColor proc - supports other background colors.
    * force theme change if it hasn't been done yet.

'''Version 1.9 ''' 2016-5-16
    * Clean up leftover default variables from the global namespace.

'''Version 1.8 ''' 2016-5-15
    * Fixed a problem with leftover traces.
    * Fixed destroy cleanup of variables.

'''Version 1.7 ''' 2016-5-11
    * Fixed scaling.
    * Improved size of indicator character.

'''Version 1.6 ''' 2016-5-10
    * Added propagateBinds routine
    * Handle -style option -- loads styling     * force theme change if it hasn't been done yet.from the ttk::style
    * Was missing -font
    * Fixed a bug for configure -variable

<<enddiscussion>>

** Screenshot **

[Scaled-checkbutton-image]

** Discussion **

[dbohdan] 2016-05-12: The fact that you have a styling for each of the 22 themes is impressive.

Could you put a high-DPI screenshot of the widget on this page?

[bll]  2016-5-12:  Well, I actually don't have a 4K screen to test with.  But I can set a windows VM to 3840x2160 video mode.
Which I can then view in VirtualBox's scaled mode (it's quite horrible).  The image below was made with Window's 
snipping tool inside the VM with
[tk scaling] set to 2.67 (192 dpi).  Windows mentioned 192 dpi when I set the custom text size to 200%, so I used that number.
On the left is a standard [ttk::checkbutton], on the right is the scaled checkbutton.

[dbohdan] 2016-05-13: Looks good! I've moved the screenshot higher on the page.

<<categories>>Widget