** 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. I will be dropping support for the 'checkButtonScaled' version below, and it will be removed from this page at a later date. [img-scheckbutton] <>Code ====== #!/usr/bin/tclsh # # Copyright 2018 Brad Lanam Walnut Creek, CA # # TODO: state handling # TODO: indicator color readonly/disabled state colors. 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) [list [self] destruct] bind $vars(widget) +[list [self] setvalue] bind $vars(label) +[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 ====== <> ---- ** 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 <> 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. <>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 <> ** 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. <>Widget