'''Current Version: 1.8''' [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] <>Code ====== #!/usr/bin/tclsh # # Written by Brad Lanam 2016-4-26 # This code is in the public domain # # This package should be required _after_ tk scaling is set. # # Check Buttons: # Substitute checkButtonScaled instead of ttk::checkbutton # # checkButtonScaled .cb -variable var1 # # Radio Buttons: # Substitute radioButtonScaled instead of ttk::radiobutton # # radioButtonScaled .rb -variable var1 -value 2 # # If you need to bind to the button, set up your binds, then call: # scaledButton::propagateBinds # # 2016-5--- version 1.8 # added radio button support. # 2016-5-11 version 1.7 # fixed scaling # indicator character is scaled better. # 2016-5-10 version 1.6 # propagateBinds routine # process -style option # -font # fix for configure of -variable # 2016-5-10 version 1.5 # fix typo. # bug fix for destroy # 2016-5-9 Draft 5 (version 1.4) # passes checkbutton.test # - except for recreating a variable after unsetting it # since that can't be traced, don't know how that would work. # passes ttk.test # 2016-5-9 Draft 4 (version 1.3) # accidental upload # 2016-5-9 Draft 3 (version 1.2) # fixed padding/border values to be in points # 2016-5-8 Draft 2 (version 1.1) # checkboxes now size correctly # adjusted sizing and padding for all checkboxes # -textvariable is working # 2016-5-5 Draft 1 (version 1.0) # # TO DO: # argument checks in widgetProcess # argument check in scaledButton # return proper codes in widgetProcess # # Testing: # states # active 2016-5-5 # disabled 2016-5-5 # focus 2016-5-9 # pressed 2016-5-5 # selected 2016-5-5 # background 2016-5-5 # readonly 2016-5-9 not for checkbuttons # alternate 2016-5-9 # invalid does not appear to be implemented # hover 2016-5-9 # basic checkbox functionality: # select on 2016-5-5 # select off 2016-5-5 # enter, leave, press, release 2016-5-5 # space bar 2016-5-9 # no -variable 2016-5-9 # -height # -command 2016-5-9 # -compound 2016-5-9 # -cursor 2016-5-9 # -image 2016-5-9 # -offvalue 2016-5-5 # -onvalue 2016-5-5 # -takefocus 2016-5-8 # -takefocus w/prefix # -text 2016-5-5 # -textvariable 2016-5-8 # -underline 2016-5-8 # -variable 2016-5-5 # -font # -style 2016-5-10 # -value 2016-5-11 # instate # w/o script 2016-5-9 # w/script # state # no arguments 2016-5-9 # return value with arguments 2016-5-9 # with arguments 2016-5-9 # map # -background # -foreground # invoke 2016-5-9 # configure # -background 2016-5-8 # -command 2016-5-9 # -compound 2016-5-9 # -cursor 2016-5-9 # -foreground 2016-5-8 # -image 2016-5-9 # -offvalue 2016-5-8 # -onvalue 2016-5-8 # -takefocus # -takefocus w/prefix # -text 2016-5-8 # -textvariable 2016-5-9 # -underline 2016-5-9 # -variable 2016-5-9 # -font # -style # package require Tk package provide scaledButton 1.8 # for testing if { 0 } { if { 1 } { tk scaling -displayof . 1.388888 } set auto_path [linsert $auto_path 0 [file join [file dirname [info script]] .. code]] package require options package require uiutils set ::bdjopt [options new] uiutils::initUI uiutils::initUIStyles [lindex $::argv 0] } proc checkButtonScaled { nm args } { return [::scaledButton::scaledButton $nm -type check {*}$args] } proc radioButtonScaled { nm args } { return [::scaledButton::scaledButton $nm -type radio {*}$args] } namespace eval scaledButton { variable vars # vars(theme.current) - the current theme setting proc _lighten { col {count 1} } { scan $col "#%2x%2x%2x" r g b set adj 1.10 for {set i 0} {$i < $count} {incr i} { set r [expr {min(round(double($r)*$adj),255)}] set g [expr {min(round(double($g)*$adj),255)}] set b [expr {min(round(double($b)*$adj),255)}] } return [format {#%02x%02x%02x} $r $g $b] } proc _darken { col {count 1} } { scan $col "#%2x%2x%2x" r g b set adj 0.80 for {set i 0} {$i < $count} {incr i} { set r [expr {max(round(double($r)*$adj),0)}] set g [expr {max(round(double($g)*$adj),0)}] set b [expr {max(round(double($b)*$adj),0)}] } return [format {#%02x%02x%02x} $r $g $b] } proc _init { } { variable vars set vars(theme.current) {} # unicode: # X mark # 00d7 multiplication sign # 2715 multiplication x # 2716 heavy multiplication sign (doesn't look good in bold) # 2a09 n-ary times operator # 2a2f vector/cross product # checkmark: # 2713 checkmark (dingbats) # 2714 heavy checkmark (dingbats) # radio buttons: # These could be used, but all of the current radio button # have some sort of border, and there's no way to overlay characters # in Tcl. # ◉ \u25C9 # ○ \u25CB # ● \u25CF # ◯ \u25EF # ◆ \u25C6 # ◇ \u25C7 # ◈ \u25C8 # ⚫ \u26AB # ⨀ \u2A00 # ⬤ \u2B24 # # bg - background ** required # the background usually doesn't change # bg.disabled - background disabled # bg.pressed - background pressed # bg.active - background active # foreground is the color of the text # sometimes the foreground disabled color is changed # fg - foreground ** required # fg.disabled - background disabled # fg.pressed - background pressed # fg.active - background active # indicatorcolor - indicator ** required # indicatorcolor.disabled # indicatorcolor.pressed # indicatorcolor.active # selectcolor - indicator color when selected # selectcolor.disabled # selectcolor.pressed # selectcolor.active # the character foreground will default to the foreground color # checkchar - checkbutton character # charfg - checkbutton character foreground normal # charfg.disabled # charfg.pressed # charfg.active # bordercolor - border background normal # bordercolor.disabled # bordercolor.pressed # bordercolor.active # STATUS: # alt # 2016-5-5: border color is listed as 414141, # but that seemed too dark. # aqua: # 2016-5-9: There does not appear to be any way to get the # windows's current disabled state, so the 'background' state # cannot be used. # aquativo # 2016-5-5: the border color does not change on selection, but # I put in the dark blue border for 'active' # xpnative # 2016-5-5: no unicode character display. Substituted an 'x'. # set vars(theme.dict) [dict create \ Alt [list \ -bg #d9d9d9 \ -bg.active #ececec \ -fg #000000 \ -fg.disabled #a3a3a3 \ -bordercolor [_darken #d9d9d9] \ -bordercolor.disabled [_darken #d9d9d9] \ -bordercolor.active [_darken #d9d9d9] \ -indicatorcolor #ffffff \ -indicatorcolor.disabled #d9d9d9 \ -indicatordiameter 7p \ -borderwidth 2 \ -checkchar \u2714 \ -charfg.disabled #a3a3a3 \ -padding 2 \ ] \ Aqua [list \ -bg #ececec \ -bg.active #ececec \ -fg #000000 \ -fg.disabled #000000 \ -indicatorcolor #ffffff \ -indicatorcolor.active #ffffff \ -indicatorcolor.disabled #f6f6f6 \ -indicatordiameter 9.5p \ -selectcolor #3b99fc \ -selectcolor.active #3b99fc \ -selectcolor.pressed #3b99fc \ -selectcolor.disabled #f6f6f6 \ -selectcolor.background #f6f6f6 \ -checkchar \u2714 \ -charfg #ffffff \ -charfg.active #ffffff \ -charfg.pressed #ffffff \ -charfg.disabled #979797 \ ] \ Aquablue [list \ -bg #f6f4f2 \ -bg.active #f6f4f2 \ -bg.pressed #f6f4f2 \ -fg #000000 \ -fg.disabled #9e928a \ -bordercolor #ae9e8e \ -bordercolor.active #ae9e8e \ -bordercolor.pressed #ae9e8e \ -bordercolor.disabled #ae9e8e \ -indicatorcolor #ffffff \ -indicatorcolor.disabled #ffffff \ -indicatordiameter 9p \ -selectcolor.disabled #ffffff \ -checkchar \u2714 \ -charfg.disabled #b5b2ad \ -relief flat \ ] \ Aquativo [list \ -bg #fafafa \ -bg.disabled #e3e1dd \ -bg.active #c1d2ee \ -bg.pressed #bab5ab \ -fg #000000 \ -fg.disabled #565248 \ -bordercolor #bab5ab \ -bordercolor.active #1c5180 \ -bordercolor.disabled #bab5ab \ -indicatorcolor #e8e8e8 \ -indicatorcolor.active #e8e8e8 \ -indicatorcolor.pressed #e8e8e8 \ -indicatorcolor.disabled #e8e8e8 \ -indicatordiameter 9.5p \ -selectcolor #3f97e2 \ -selectcolor.active #3f97e2 \ -selectcolor.disabled #3f97e2 \ -checkchar \u2715 \ -charfg #000000 \ -relief flat \ -padding 0 \ ] \ Arc [list \ -bg #f5f6f7 \ -bg.active #fbfcfc \ -bg.disabled #fbfcfc \ -fg #000000 \ -fg.disabled #a9acb2 \ -bordercolor #cfd6e6 \ -bordercolor.active #cfd6e6 \ -bordercolor.pressed #cfd6e6 \ -bordercolor.disabled #cfd6e6 \ -indicatorcolor #ffffff \ -indicatorcolor.disabled #ffffff \ -indicatordiameter 10.5p \ -selectcolor #5294e2 \ -selectcolor.active #5294e2 \ -selectcolor.pressed #5294e2 \ -selectcolor.disabled #ffffff \ -checkchar \u2714 \ -charfg #ffffff \ -charfg.active #ffffff \ -charfg.pressed #ffffff \ -charfg.disabled #ffffff \ -relief flat \ -padding 2 \ ] \ Black [list \ -bg #424242 \ -bg.active #626262 \ -fg #ffffff \ -fg.disabled #a9a9a9 \ -bordercolor #626262 \ -bordercolor.active #626262 \ -bordercolor.disabled #626262 \ -indicatorcolor #ffffff \ -indicatorcolor.disabled #ffffff \ -checkchar \u2715 \ -charfg #000000 \ -charfg.active #000000 \ -charfg.pressed #000000 \ -charfg.disabled #000000 \ -padding 0 \ ] \ Blue [list \ -bg #6699cc \ -bg.active #6699cc \ -bg.pressed #6699cc \ -fg #000000 \ -fg.disabled #666666 \ -indicatorcolor #a1c0df \ -indicatorcolor.active #a1c0df \ -indicatorcolor.disabled #a1c0df \ -indicatordiameter 12p \ -relief flat \ -bordercolor #2d2d66 \ -bordercolor.active #ffffff \ -bordercolor.disabled #2d2d66 \ -bordercolor.pressed #ffffff \ -checkchar \u00d7 \ -charfg.active #000000 \ -charfg.pressed #000000 \ -charfg.disabled #a1c0df \ -padding 0 \ ] \ Blueelegance [list \ -bg #d8d8d8 \ -bg.active #d8d8d8 \ -fg #000000 \ -fg.active #000000 \ -fg.disabled #747474 \ -bordercolor #000000 \ -bordercolor.active #000000 \ -bordercolor.pressed #000000 \ -bordercolor.disabled #000000 \ -indicatorcolor #627799 \ -indicatorcolor.disabled #627799 \ -checkchar \u2715 \ -charfg #ffffff \ -charfg.active #ffffff \ -charfg.disabled #ffffff \ -relief flat \ -padding 0 \ ] \ Clam [list \ -bg #dcdad5 \ -fg #000000 \ -fg.disabled #999999 \ -indicatorcolor #ffffff \ -indicatorcolor.disabled #dcdad5 \ -checkchar \u2715 \ -charfg.disabled #000000 \ ] \ Classic [list \ -bg #d9d9d9 \ -bg.active #ececec \ -fg #000000 \ -fg.disabled #a3a3a3 \ -indicatorcolor #d9d9d9 \ -indicatorcolor.active #d9d9d9 \ -indicatorcolor.disabled #d9d9d9 \ -indicatordiameter 6.5p \ -selectcolor #b03060 \ -selectcolor.active #b03060 \ -selectcolor.disabled #b03060 \ -selectrelief sunken \ -relief raised \ -borderwidth 2 \ -checkchar {} \ -padding 3 \ ] \ Clearlooks [list \ -bg #efebe7 \ -bg.active #f5f3f0 \ -fg #000000 \ -fg.disabled #b5b3ac \ -bordercolor #ae9e8e \ -bordercolor.active #ae9e8e \ -bordercolor.pressed #ae9e8e \ -bordercolor.disabled #ae9e8e \ -indicatorcolor #ffffff \ -indicatorcolor.disabled #ffffff \ -indicatordiameter 9p \ -selectcolor.disabled #ffffff \ -checkchar \u2714 \ -charfg.disabled #b5b2ad \ -relief flat \ ] \ Default [list \ -bg #d9d9d9 \ -bg.active #ececec \ -fg #000000 \ -fg.disabled #a3a3a3 \ -indicatorcolor #ffffff \ -indicatorcolor.disabled #ffffff \ -indicatordiameter 7p \ -selectcolor #4a6984 \ -selectcolor.active #4a6984 \ -selectcolor.disabled #4a6984 \ -checkchar {} \ -padding 0 \ ] \ Keramik [list \ -bg #cccccc \ -bg.active #cccccc \ -fg #000000 \ -fg.disabled #aaaaaa \ -indicatorcolor #ffffff \ -indicatordiameter 7p \ -checkchar \u00d7 \ -charfg.active #000000 \ -relief ridge \ -borderwidth 4 \ -padding 0 \ ] \ Keramik_alt [list \ -bg #cccccc \ -bg.active #cccccc \ -fg #000000 \ -fg.disabled #aaaaaa \ -indicatorcolor #ffffff \ -indicatordiameter 7p \ -checkchar \u00d7 \ -charfg.active #000000 \ -relief ridge \ -borderwidth 4 \ -padding 0 \ ] \ Kroc [list \ -bg #fcb64f \ -bg.active #694418 \ -fg #000000 \ -fg.active #ffffff \ -fg.disabled #b2b2b2 \ -indicatorcolor #fcb64f \ -indicatorcolor.disabled #fcb64f \ -checkchar \u2714 \ -charfg #694418 \ -charfg.active #694418 \ -charfg.disabled #694418 \ -indicatordiameter 13p \ -activerelief raised \ -padding 0 \ ] \ Plastik [list \ -bg #efefef \ -bg.active #efefef \ -fg #000000 \ -fg.disabled #aaaaaa \ -indicatorcolor #f2f2f2 \ -indicatorcolor.active #657a9e \ -indicatorcolor.disabled #f2f2f2 \ -indicatordiameter 10p \ -bordercolor #8c8d90 \ -bordercolor.disabled #8c8d90 \ -checkchar \u2716 \ -charfg.active #000000 \ -charfg.disabled #000000 \ -relief flat \ -padding 0 \ ] \ Radiance [list \ -bg #f6f4f2 \ -bg.active #f6f3f0 \ -fg #000000 \ -fg.disabled #9e928a \ -indicatorcolor #ffffff \ -indicatorcolor.disabled #e6e1dc \ -indicatordiameter 10p \ -bordercolor #ae9e8e \ -bordercolor.active #ae9e83 \ -bordercolor.disabled #ae9e83 \ -selectcolor #f27c4d \ -selectcolor.active #f27c4d \ -checkchar \u2714 \ -charfg #79432d \ -charfg.active #79432d \ -charfg.disabled #ae9e8e \ -relief flat \ -padding 0 \ ] \ Vista [list \ -bg #f0f0f0 \ -bg.active #f0f0f0 \ -bg.pressed #f0f0f0 \ -fg #000000 \ -fg.disabled #6d6d6d \ -bordercolor #8f8f8f \ -bordercolor.active #8f8f8f \ -bordercolor.pressed #8f8f8f \ -bordercolor.disabled #8f8f8f \ -indicatorcolor #d0d4d9 \ -indicatorcolor.active #a8c8e1 \ -indicatorcolor.pressed #7ea6c6 \ -indicatorcolor.disabled #f0f0f0 \ -checkchar \u2713 \ -charfg #4b6097 \ -charfg.active #4b6097 \ -charfg.pressed #4b6097 \ -charfg.disabled #d5d5d5 \ -relief flat \ ] \ Waldorf [list \ -bg #d1d1d1 \ -fg #000000 \ -fg.disabled #595959 \ -indicatorcolor #ffffff \ -indicatorcolor.disabled #dbdbdb \ -indicatordiameter 8p \ -selectcolor #a7a7a7 \ -selectcolor.active #a7a7a7 \ -selectcolor.disabled #dbdbdb \ -bordercolor #8a8a8a \ -bordercolor.disabled #8a8a8a \ -bordercolor.active #8a8a8a \ -checkchar \u2714 \ -charfg #ffffff \ -charfg.active #ffffff \ -charfg.disabled #8a8a8a \ -relief flat \ ] \ Winnative [list \ -bg #f0f0f0 \ -bg.active #f0f0f0 \ -bg.pressed #f0f0f0 \ -fg #000000 \ -fg.disabled #6d6d6d \ -borderwidth 2 \ -bordercolor #f0f0f0 \ -bordercolor.active #f0f0f0 \ -bordercolor.pressed #f0f0f0 \ -bordercolor.disabled #f0f0f0 \ -indicatorcolor #ffffff \ -indicatorcolor.active #ffffff \ -indicatorcolor.pressed #ffffff \ -indicatorcolor.disabled #f0f0f0 \ -indicatordiameter 7p \ -checkchar \u2713 \ -charfg.active #0000ff \ -charfg.pressed #000000 \ -charfg.disabled #a0a0a0 \ -padding 3 \ ] \ Winxpblue [list \ -bg #ece9d8 \ -bg.active #c1d2ee \ -bg.pressed #bab5ab \ -fg #000000 \ -fg.disabled #565248 \ -indicatorcolor #f9f9f8 \ -indicatorcolor.disabled #f9f9f8 \ -indicatordiameter 9p \ -bordercolor #1c5180 \ -bordercolor.disabled #1c5180 \ -bordercolor.active #1c5180 \ -bordercolor.pressed #1c5180 \ -checkchar \u2714 \ -charfg #21a121 \ -charfg.active #21a121 \ -charfg.disabled #21a121 \ -relief flat \ -padding 0 \ ] \ Xpnative [list \ -bg #ece9d8 \ -bg.active #ece9d8 \ -bg.pressed #ece9d8 \ -fg #000000 \ -fg.disabled #565248 \ -indicatorcolor #ececec \ -indicatorcolor.active #fdd891 \ -indicatorcolor.pressed #e0e0db \ -indicatorcolor.disabled #ffffff \ -indicatordiameter 9p \ -bordercolor #1c5180 \ -bordercolor.active #1c5180 \ -bordercolor.pressed #1c5180 \ -bordercolor.disabled #cac8bb \ -checkchar x \ -charfg #21a121 \ -charfg.active #21a121 \ -charfg.disabled #a0a0a0 \ -relief flat \ ] \ ] # initialize the common settings dict for {theme themedata} $vars(theme.dict) { foreach {opt} [list -indicatorcolor -bg -fg -charfg \ -bordercolor -selectcolor] { set bopt $opt if { $opt eq "-charfg" } { set bopt -fg } if { $opt eq "-bordercolor" } { set bopt -indicatorcolor } if { $opt eq "-selectcolor" } { set bopt -indicatorcolor } if { $opt eq "-disabledcolor" } { set bopt -indicatorcolor } if { ! [dict exists $themedata ${opt}] } { set val [dict get $themedata ${bopt}] dict set vars(theme.dict) $theme ${opt} $val dict set themedata ${opt} $val } foreach {state p c} [list disabled _darken 1 active _lighten 1 \ pressed _lighten 1 readonly _darken 0 background _darken 0] { if { ! [dict exists $themedata $opt.$state] } { if { $opt eq "-fg" && $state eq "disabled" } { set bopt -bg } set val [dict get $themedata $bopt] if { $c != 0 } { set val [$p $val $c] } if { $opt eq "-bg" && $state eq "disabled" } { set val [dict get $themedata $opt] } if { [dict exists $themedata $bopt.$state] } { set val [dict get $themedata $bopt.$state] } dict set vars(theme.dict) $theme $opt.$state $val dict set themedata $opt.$state $val } } } foreach {opt} [list -selectrelief -activerelief] { if { ! [dict exists $themedata $opt] && [dict exists $themedata -relief] } { dict set vars(theme.dict) $theme $opt \ [dict get $themedata -relief] dict set $themedata $opt \ [dict get $themedata -relief] } } } setTheme bind . <> +[namespace current]::setTheme } proc setTheme { } { variable vars set theme [string totitle [ttk::style theme use]] set rc 0 # <> fires for many different widgets if { $vars(theme.current) ne $theme } { if { [dict exists $vars(theme.dict) $theme] } { ### need to update all the known widgets set vars(theme.current) $theme } } return $rc } proc nsjoin { ns var } { set var $ns$var if { [string match ::::* $var] } { set var [string range $var 2 end] } return $var } proc propagateBinds { w } { variable vars set blist [bind $w] foreach {b} $blist { set bscript [bind $w $b] foreach {cw} [list $w.cbouter $w.cbindicator \ $w.cbchar $w.cbspacer2 $w.cbtext] { if { ! [winfo exists $w] } { continue } bind $cw $b $bscript } } } proc updateColors { self } { variable vars set suffix {} if { [dict get $vars($self.state) disabled] } { set suffix .disabled } elseif { [dict get $vars($self.state) background] } { set suffix .background } elseif { [dict get $vars($self.state) active] } { if { [dict get $vars($self.state) pressed] } { set suffix .pressed } else { set suffix .active } } # main frame # the main frame will have a highlight and border. ${self} configure \ -background $vars($self.-bg${suffix}) # the indicator border set trelief $vars($self.-relief) if { [dict get $vars($self.state) selected] } { set trelief $vars($self.-selectrelief) } if { [dict get $vars($self.state) active] } { set trelief $vars($self.-activerelief) } ${self}.cbouter configure \ -background $vars($self.-bordercolor${suffix}) \ -relief $trelief # the indicator set tcol $vars($self.-indicatorcolor${suffix}) if { [dict get $vars($self.state) selected] } { set tcol $vars($self.-selectcolor${suffix}) } ${self}.cbindicator configure \ -background $tcol # the text in the indicator (if any) if { $vars($self.-checkchar) ne {} } { set fg $vars($self.-indicatorcolor${suffix}) set bg $vars($self.-indicatorcolor${suffix}) if { [dict get $vars($self.state) selected] } { set fg $vars($self.-charfg${suffix}) set bg $vars($self.-selectcolor${suffix}) } ${self}.cbchar configure \ -foreground $fg \ -background $bg } ${self}.cbspacer2 configure \ -foreground $vars($self.-bg${suffix}) \ -background $vars($self.-bg${suffix}) ${self}.cbtext configure \ -foreground $vars($self.-fg${suffix}) \ -background $vars($self.-bg${suffix}) } proc removeTrace { self } { if { [info exists vars($self.fqvn)] } { trace remove variable $vars($self.fqvn) [list write unset] \ [list ::scaledButton::traceVar $self] } } proc configureTextVariable { self varnm } { variable vars if { [info exists $varnm] } { set vars($self.-text) {} if { $vars($self.-textvariable) ne {} } { trace remove variable $vars($self.fqtvn) unset \ [list ::scaledButton::traceTextVar $self] } set vars($self.fqtvn) $varnm trace add variable $vars($self.fqtvn) unset \ [list ::scaledButton::traceTextVar $self] $self.cbtext configure -textvariable $vars($self.fqtvn) return 0 } return 1 } proc configureVariable { self varnm } { variable vars if { ! [winfo exists $self] } { return 1 } dict set vars($self.state) alternate 0 try { trace add variable $varnm [list write unset] \ [list ::scaledButton::traceVar $self] } on error {err res} { return 1 } removeTrace $self set vars($self.fqvn) $varnm return 0 } proc traceTextVar { self args } { variable vars lassign $args tvarnm nm2 type if { $type eq "unset" } { set ovar [$self.cbtext cget -textvariable] $self.cbtext configure -textvariable {} set vars($self.-text) {} set vars($self.-textvariable) {} set vars($self.fqtvn) {} unset $ovar } } proc traceVar { self args } { variable vars lassign $args tvarnm nm2 type if { $type eq "unset" } { dict set vars($self.state) selected 0 dict set vars($self.state) alternate 1 unset $vars($self.fqvn) set vars($self.-variable) {} set vars($self.fqvn) {} } else { dict set vars($self.state) alternate 0 if { [set $vars($self.fqvn)] eq $vars($self.-onvalue) } { dict set vars($self.state) selected 1 } else { dict set vars($self.state) selected 0 } } updateColors $self } proc selfdestroy { self } { variable vars if { [info exists vars($self.-variable)] && $vars($self.-variable) ne {} } { trace remove variable $vars($self.fqvn) [list write unset] \ [list ::scaledButton::traceVar $self] } if { [info exists vars($self.aliastoken)] } { interp alias {} $vars($self.aliastoken) {} } foreach {k} [array names vars ${self}*] { unset vars($k) } if { [info commands $self] eq $self } { rename $self {} } } proc enterMain { self } { variable vars if { ! [dict get $vars($self.state) disabled] } { dict set vars($self.state) hover 1 ::scaledButton::widgetProcess $self state hover } } proc leaveMain { self } { variable vars if { ! [dict get $vars($self.state) disabled] } { dict set vars($self.state) hover 0 ::scaledButton::widgetProcess $self state !hover } } proc enter { self } { variable vars if { ! [dict get $vars($self.state) disabled] && ! [dict get $vars($self.state) active] } { dict set vars($self.state) active 1 ::scaledButton::widgetProcess $self state {active hover} } } proc leave { self } { variable vars if { ! [dict get $vars($self.state) disabled] && [dict get $vars($self.state) active] } { dict set vars($self.state) active 0 ::scaledButton::widgetProcess $self state {!active !hover} } } proc toggle { self } { variable vars dict set vars($self.state) selected \ [expr {1-[dict get $vars($self.state) selected]}] if { $vars($self.fqvn) ne {} } { dict set vars($self.state) alternate 0 if { [dict get $vars($self.state) selected] } { set $vars($self.fqvn) $vars($self.-onvalue) } elseif { $vars($self.-type) eq "check" } { set $vars($self.fqvn) $vars($self.-offvalue) } } if { [winfo exists $self] } { if { $vars($self.-command) ne {} } { # this could be a list or a string. {*}$vars($self.-command) } } else { return -code error } return 0 } proc release { self } { variable vars if { [dict get $vars($self.state) disabled] || ! [dict get $vars($self.state) active] || ! [dict get $vars($self.state) pressed] } { return } dict set vars($self.state) pressed 0 dict set vars($self.state) focus 1 focus $self.cbtext toggle $self ; # this will also fire the trace if -variable is set. if { $vars($self.-variable) eq $self } { updateColors $self } } proc mapColorSpec { arg } { if { $arg eq "-foreground" } { set arg -fg } if { $arg eq "-background" } { set arg -bg } if { $arg eq "-disabledbg" } { set arg -bg.disabled } if { $arg eq "-selectbackground" } { set arg -selectcolor } if { $arg eq "-disabledfg" } { set arg -fg.disabled } return $arg } proc loadStyle { self } { variable vars foreach {o} [list -background -foreground -font -indicatorcolor] { set val [ttk::style lookup $vars($self.-style) $o] if { $val ne {} } { set vars($self.$o) $val } if { $o eq "-font" } { continue } foreach state [list selected disabled active \ pressed readonly focus alternate invalid \ hover background] { set val [ttk::style lookup $vars($self.-style) $o $state] if { $val ne {} } { set vars($self.$o.$state) $val } } } } proc widgetProcess { self cmd args } { variable vars set rval {} switch -exact -- $cmd { instate { set rval 1 lassign $args statespec script foreach {val} {*}$statespec { set rval [expr {$rval & [dict get $vars($self.state) $val]}] } if { $rval && $script ne {} } { return [eval $script] } } invoke { set rval [toggle $self] } state { set rlist [list] dict for {state val} $vars($self.state) { if { $val == 1 } { lappend rlist $state } } if { [info exists args] && [llength $args] > 0 } { foreach {val} {*}$args { set sval 1 if { [string match !* $val] } { set val [string range $val 1 end] set sval 0 } # append any changed states set tsval [dict get $vars($self.state) $val] if { $tsval ne $sval } { if { $tsval == 1 } { lappend rlist $state } else { lappend rlist !$state } } # and set the state dict set vars($self.state) $val $sval if { $val eq "disabled" && $sval == 1 } { dict set vars($self.state) active 0 dict set vars($self.state) pressed 0 } updateColors $self } } set rval $rlist } cget { set rval {} set arg [lindex $args 0] set arg [mapColorSpec $arg] if { [info exists vars($self.$arg)] } { set rval $vars($self.$arg) # original checkbutton returns -textvariable # when asked for -text if { $arg eq "-text" && $vars($self.-textvariable) ne {} } { set rval [set $vars($self.fqtvn)] } } } map { foreach {arg clist} $args { set arg [mapColorSpec $arg] foreach {state val} $clist { set vars($self.$arg$state) $val } } updateColors $self } configure { foreach {arg val} $args { set arg [mapColorSpec $arg] if { $arg eq "-checkchar" } { $self.cbchar configure -text $val } if { $arg eq "-value" } { set vars($self.-onvalue) $val } if { $arg eq "-indicatordiameter" } { $self.cbindicator configure -height $val -width $val $self.cbchar -font [createFont $val] } if { $arg eq "-cursor" } { configCursor $self $val } if { $arg eq "-textvariable" } { if { $val ne {} } { set varnm [nsjoin $vars($self.ns) $val] set rc [configureTextVariable $self $varnm] if { $rc != 0 } { return -code error {} } } } if { $arg eq "-variable" } { set varnm [nsjoin $vars($self.ns) $val] set rc [configureVariable $self $varnm] if { $rc != 0 } { return -code error $::errorInfo } set vars($self.fqvn) $varnm } if { $arg eq "-style" } { loadStyle $self } if { $arg eq "-state" } { if { $val eq "normal" } { set val !disabled widgetProcess $self state $val } } else { set vars($self.$arg) $val } processArguments $self configureLabel $self updateColors $self } } default { } } return -code ok $rval } proc configCursor { self val } { $self.cbouter configure -cursor $val $self.cbindicator configure -cursor $val $self.cbchar configure -cursor $val $self.cbtext configure -cursor $val $self.cbspacer2 configure -cursor $val } proc createFont { sz } { variable vars set sz [string trimright $sz p] if { ! [info exists vars(cache.font.$sz)] } { font create _cbsFont$sz font configure _cbsFont$sz -size [expr {round($sz+1)}] -weight bold set vars(cache.font.$sz) 1 } return _cbsFont$sz } proc processArguments { self } { variable vars try { dict set vars($self.state) alternate 1 if { $vars($self.-variable) ne {} } { if { [info exists $vars($self.fqvn)] } { dict set vars($self.state) alternate 0 if { [set $vars($self.fqvn)] eq $vars($self.-onvalue) } { dict set vars($self.state) selected 1 } else { dict set vars($self.state) selected 0 } } } set vars($self.textonly) 0 set vars($self.imageonly) 0 if { $vars($self.-compound) eq "text" } { set vars($self.textonly) 1 } if { $vars($self.-compound) eq "image" || ($vars($self.-compound) eq "none" && $vars($self.-image) ne {}) } { set vars($self.imageonly) 1 } } on error {err res} { return -code error {widget has been destroyed} } return 0 } proc configureLabel { self } { variable vars set cbtextargs [list \ -justify left \ -borderwidth 0 \ -takefocus $vars($self.-takefocus) \ ] foreach {o} [list -font -height -underline] { if { $vars($self.$o) ne {} } { lappend cbtextargs $o $vars($self.$o) } } if { ! $vars($self.imageonly) } { lappend cbtextargs -text $vars($self.-text) } if { ! $vars($self.imageonly) && $vars($self.-textvariable) ne {} } { lappend cbtextargs -textvariable $vars($self.fqtvn) } if { $vars($self.textonly) && $vars($self.-image) ne {} } { lappend cbtextargs -image {} } if { ! $vars($self.textonly) && $vars($self.-image) ne {} } { lappend cbtextargs -image $vars($self.-image) } if { $vars($self.-compound) ne "text" && $vars($self.-compound) ne "image" } { lappend cbtextargs -compound $vars($self.-compound) } else { lappend cbtextargs -compound none } ${self}.cbtext configure {*}$cbtextargs } proc scaledButton { nm args } { variable vars set vars($nm.ns) [uplevel namespace current] array set opts $args # defaults set vars($nm.-borderwidth) [expr {1/[tk scaling]}]p set vars($nm.-indicatordiameter) 8p set vars($nm.-onvalue) 1 set vars($nm.-offvalue) 0 set vars($nm.-cursor) {} set vars($nm.-takefocus) 1 set vars($nm.-relief) sunken set vars($nm.-selectrelief) sunken set vars($nm.-activerelief) sunken set vars($nm.-text) {} set vars($nm.-textvariable) {} set vars($nm.state) [list selected 0 disabled 0 active 0 \ pressed 0 readonly 0 focus 0 alternate 1 invalid 0 \ hover 0 background 0] set vars($nm.-padding) [expr {1/[tk scaling]}]p set vars($nm.-anchor) center set vars($nm.-image) {} set vars($nm.-compound) none set vars($nm.-underline) {} set vars($nm.-command) {} set vars($nm.-variable) $nm set vars($nm.-height) {} set vars($nm.-style) {} set vars($nm.-font) {} set vars($nm.-type) check set vars($nm.-value) 1 set vars($nm.-checkchar) {} set vars($nm.-radiochar) \u26AB # override with settings from theme set theme [string totitle [ttk::style theme use]] set themedata [dict get $vars(theme.dict) $theme] dict for {opt val} $themedata { set vars($nm.$opt) $val } set vars($nm.-padx) $vars($nm.-padding) set vars($nm.-pady) $vars($nm.-padding) # override with user settings foreach {o} [list \ -bordercolor -borderwidth -checkchar \ -command -compound -cursor -font -height -image \ -indicatordiameter -offvalue -onvalue \ -padx -pady -radiochar -relief -style -takefocus -takefocus \ -text -type -underline -value -variable \ ] { if { [info exists opts($o)] && $opts($o) ne {} } { set vars($nm.$o) $opts($o) } } if { $vars($nm.-type) eq "radio" } { set vars($nm.-char) $vars($nm.-radiochar) set vars($nm.-onvalue) $vars($nm.-value) } else { set vars($nm.-char) $vars($nm.-checkchar) } set sz $vars($nm.-indicatordiameter) # main frame # the main frame will have a highlight and border. frame ${nm} -padx $vars($nm.-padx) -pady $vars($nm.-pady) # the indicator border set bsz $vars($nm.-borderwidth) frame ${nm}.cbouter \ -borderwidth ${bsz} \ -relief $vars($nm.-relief) set val [expr {1/[tk scaling]}]p pack ${nm}.cbouter -in ${nm} \ -side left -expand false -padx ${val}p -pady ${val}p -fill none # the indicator frame ${nm}.cbindicator \ -width $sz \ -height $sz \ -highlightthickness 0 \ -relief flat pack ${nm}.cbindicator -in ${nm}.cbouter \ -expand false -padx 0 -pady 0 -ipadx 0 -ipady 0 -fill none pack propagate ${nm}.cbindicator false # the text in the indicator (if any) if { $vars($nm.-char) ne {} } { label ${nm}.cbchar \ -text $vars($nm.-char) \ -justify center \ -font [createFont $sz] \ -highlightthickness 0 \ -borderwidth 0 pack ${nm}.cbchar -in ${nm}.cbindicator -padx 0 -pady 0 -ipadx 0 -ipady 0 } label ${nm}.cbspacer2 \ -text {} \ -justify left \ -highlightthickness 0 \ -borderwidth 0 pack ${nm}.cbspacer2 -in ${nm} \ -side left \ -ipadx 0.25p \ -ipady 1p label ${nm}.cbtext pack ${nm}.cbtext -in ${nm} \ -anchor $vars($nm.-anchor) \ -side left \ -ipadx 1p \ -ipady 1p if { $vars($nm.-style) ne {} } { loadStyle $nm } rename $nm ::scaledButton::$nm ; # main frame command set vars($nm.aliastoken) [interp alias {} $nm {} \ ::scaledButton::widgetProcess $nm] set varnm [nsjoin $vars($nm.ns) $vars($nm.-variable)] set rc [configureVariable $nm $varnm] if { $rc != 0 } { destroy $nm return -code error $::errorInfo } set o -textvariable if { [info exists opts($o)] && $opts($o) ne {} } { set varnm [nsjoin $vars($nm.ns) $opts($o)] set rc [configureTextVariable $nm $varnm] if { $rc != 0 } { destroy $nm return -code ok {} } set vars($nm.$o) $opts($o) } set rc [processArguments $nm] if { $rc != 0 } { destroy $nm return -code ok {} } if { ! [winfo exists $nm] } { selfdestroy $nm return -code error {widget has been destroyed} } if { $vars($nm.-cursor) ne {} } { configCursor $nm $vars($nm.-cursor) } configureLabel $nm updateColors $nm bind $nm \ +[list ::scaledButton::selfdestroy $nm] bind $nm \ +[list ::scaledButton::enterMain $nm] bind $nm \ +[list ::scaledButton::leaveMain $nm] foreach {w} [list $nm.cbouter $nm.cbindicator $nm.cbchar $nm.cbtext] { if { ! [winfo exists $w] } { continue } bind $w \ +[list ::scaledButton::toggle $nm] bind $w \ +[list ::scaledButton::enter $nm] bind $w \ +[list ::scaledButton::leave $nm] bind $w \ +[list ::scaledButton::widgetProcess $nm state {active pressed}] bind $w \ +[list ::scaledButton::release $nm] } return -code ok $nm } # initialize _init } if { 0 } { proc do5000 { } { .cbon configure -background green .cboff configure -foreground blue } proc toggleState { s } { set cs [.cbonoff state $s] set val {} if { $s in $cs } { set val ! } .cbonoff state $val$s return } proc setUline { } { .cbonoff configure -underline $::u } proc setCursor { } { .cbonoff configure -cursor $::c } proc setText { } { .cbonoff configure -text $::t } proc setTextVariable { } { .cbonoff configure -textvariable $::tv } proc setOnvalue { } { .cbonoff configure -onvalue $::onvalue } proc setOffvalue { } { .cbonoff configure -offvalue $::offvalue } proc setVariable { } { .cbonoff configure -variable $::var } proc setCommand { } { .cbonoff configure -command $::cmd } proc setImage { } { set img [image create photo -file $::image] .cbonoff configure -image $img } proc setCompound { } { .cbonoff configure -compound $::compound } proc putstate { w } { puts "$w:[$w state]" } proc demo { } { set ::onoff ON set ::onofflab ONOFF set ::u 1 set ::c {} set ::t ONOFF set ::tv ::onofflab set ::onvalue ON set ::offvalue OFF set ::on 1 set ::off 0 set ::var ::onoff set ::cmd {} set ::image {} set ::compound none ttk::label .laa -text {basic display check} scaledButton .cbon -variable on -text hello \ -command [list putstate .cbon] scaledButton .cbond -variable on -text hello .cbond state disabled scaledButton .cbonr -variable on -text hello .cbonr state readonly scaledButton .cboff -variable off -text hello \ -command [list putstate .cboff] scaledButton .cboffd -variable off -text hello .cboffd state disabled scaledButton .cboffr -variable off -text hello .cboffr state readonly ttk::label .lbb -text { } pack .laa .cbon .cbond .cbonr .cboff .cboffd .cboffr .lbb \ -side top -anchor w scaledButton .cbonoff -variable onoff -textvariable ::onofflab \ -onvalue ON -offvalue OFF -underline 1 \ -command [list putstate .cbonoff] pack .cbonoff -side top -anchor w ttk::frame .fa ttk::label .lonofflab -text {Value: } ttk::label .lonoff -textvariable onoff pack .fa -side top -anchor w pack .lonofflab .lonoff -in .fa -side left -anchor w scaledButton .cbonoffd -text disabled \ -command [list toggleState disabled] pack .cbonoffd -side top -anchor w scaledButton .cbonoffa -text active \ -command [list toggleState active] pack .cbonoffa -side top -anchor w scaledButton .cbonoffp -text pressed \ -command [list toggleState pressed] pack .cbonoffp -side top -anchor w scaledButton .cbonoffr -text readonly \ -command [list toggleState readonly] pack .cbonoffr -side top -anchor w ttk::frame .fb ttk::label .lb -text {Underline: } ttk::entry .eb -textvariable u bind .eb [list setUline] pack .fb -side top -anchor w pack .lb .eb -in .fb -side left -anchor w ttk::frame .fc ttk::label .lc -text {Cursor: } ttk::entry .ec -textvariable c bind .ec [list setCursor] pack .fc -side top -anchor w pack .lc .ec -in .fc -side left -anchor w ttk::frame .fd ttk::label .ld -text {Text: } ttk::entry .ed -textvariable t bind .ed [list setText] pack .fd -side top -anchor w pack .ld .ed -in .fd -side left -anchor w ttk::frame .fe ttk::label .le -text {Text Variable: } ttk::entry .ee -textvariable tv bind .ee [list setTextVariable] pack .fe -side top -anchor w pack .le .ee -in .fe -side left -anchor w ttk::frame .ff ttk::label .lf -text {On Value } ttk::entry .ef -textvariable ::onvalue bind .ef [list setOnvalue] pack .ff -side top -anchor w pack .lf .ef -in .ff -side left -anchor w ttk::frame .fg ttk::label .lg -text {Off Value } ttk::entry .eg -textvariable ::offvalue bind .eg [list setOffvalue] pack .fg -side top -anchor w pack .lg .eg -in .fg -side left -anchor w ttk::frame .fh ttk::label .lh -text {Variable: } ttk::entry .eh -textvariable ::var bind .eh [list setVariable] pack .fh -side top -anchor w pack .lh .eh -in .fh -side left -anchor w ttk::frame .fi ttk::label .li -text {Command: } ttk::entry .ei -textvariable ::cmd bind .ei [list setCommand] pack .fi -side top -anchor w pack .li .ei -in .fi -side left -anchor w ttk::frame .fj ttk::label .lj -text {Image: } ttk::entry .ej -textvariable ::image bind .ej [list setImage] pack .fj -side top -anchor w pack .lj .ej -in .fj -side left -anchor w ttk::frame .fk ttk::label .lk -text {Image: } ttk::entry .ek -textvariable ::compound bind .ek [list setCompound] pack .fk -side top -anchor w pack .lk .ek -in .fk -side left -anchor w update after 5000 do5000 } demo } ====== <> <>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