Attachment "checkButtonScaled.tcl" to
ticket [5d991b82]
added by
bll
2018-01-26 18:34:33.
#!/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
#
# To change the background color (if you have a non-standard background):
# checkButtonScaled::changeColor <background-color>
#
# 2018-1-22 version 1.20
# Remove bad code on trace unset.
# 2018-1-5 version 1.19
# Fixed character scaling
# 2018-1-5 version 1.18
# Attempt to fix scaling issues.
# 2017-8-19 version 1.17
# Reworked to scale by the size of the font.
# 2016-8-16 version 1.16
# Removed propagateBinds routine; no longer needed. Binds on the
# main container are executed for all contained widgets.
# Fixed focus state reporting.
# 2016-7-5 version 1.15
# Fix propagateBinds check for window existence.
# 2016-7-4 version 1.14
# Change spacer to be a frame.
# Better handle mac os x's crazy amount of extra label padding.
# 2016-7-2 version 1.13
# Focus fixes.
# Highlight fixes.
# Fixed space bar toggle.
# 2016-6-14 version 1.12
# Keep disabled background the same color as the background color.
# Disabled background colors probably looks better when the
# checkbutton has a label.
# 2016-6-9 version 1.11
# Fixed trace on configure of same variable name.
# 2016-6-3 version 1.10
# improved efficiency
# added changeColor proc
# force theme change if it hasn't been done yet.
# 2016-5-16 version 1.9
# clean up default variables in global namespace
# 2016-5-15 version 1.8
# fixed problems with traces
# fixed cleanup of variables on destroy.
# 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)
#
package require Tk
proc checkButtonScaled { nm args } {
return [::checkButtonScaled::checkButtonScaled $nm {*}$args]
}
namespace eval ::checkButtonScaled {
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)
#
# 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 (background)
# 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
# -border {bg|other}
#
# 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 \
-border bg \
-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 \
-border bg \
-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 \
-border other \
-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 #fafafa \
-bg.active #c1d2ee \
-bg.pressed #bab5ab \
-fg #000000 \
-fg.disabled #565248 \
-border other \
-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 #f5f6f7 \
-fg #000000 \
-fg.disabled #a9acb2 \
-border other \
-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 \
-border other \
-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 \
-border other \
-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 \
-border other \
-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 \
-border bg \
-indicatorcolor #ffffff \
-indicatorcolor.disabled #dcdad5 \
-checkchar \u2715 \
-charfg.disabled #000000 \
] \
Classic [list \
-bg #d9d9d9 \
-bg.active #ececec \
-fg #000000 \
-fg.disabled #a3a3a3 \
-border bg \
-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 \
-border other \
-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 \
-border bg \
-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 \
-border bg \
-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 \
-border bg \
-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 \
-border bg \
-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 \
-border bg \
-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 \
-border other \
-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 \
-border other \
-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 \
-border other \
-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 \
-border other \
-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 \
-border other \
-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 \
-border other \
-bordercolor #1c5180 \
-bordercolor.active #1c5180 \
-bordercolor.pressed #1c5180 \
-bordercolor.disabled #cac8bb \
-checkchar x \
-charfg #21a121 \
-charfg.active #21a121 \
-charfg.disabled #a0a0a0 \
-relief flat \
] \
]
setTheme
bind . <<ThemeChanged>> +[namespace current]::setTheme
set vars(macosx) false
if { $::tcl_platform(os) eq "Darwin" } {
set vars(macosx) true
}
set vars(usespacer) true
if { $vars(macosx) &&
[package vcompare [info patch] 8.6.6] < 0 } {
set vars(usespacer) false
}
}
proc _initCommon { theme } {
variable vars
# initialize the common settings
set themedata [dict get $vars(theme.dict) $theme]
foreach {opt} [list -indicatorcolor -bg -fg -charfg \
-bordercolor -selectcolor -highlightcolor] {
set bopt $opt
if { $opt eq "-charfg" } {
set bopt -fg
}
if { $opt eq "-highlightcolor" } {
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 0 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]
}
}
}
proc changeColor { bg } {
variable vars
set theme [string totitle [ttk::style theme use]]
if { $theme ne $vars(theme.current) } {
setTheme
}
set light [_lighten $bg]
set dark [_darken $bg]
dict set vars(theme.dict) $vars(theme.current) -bg $bg
dict set vars(theme.dict) $vars(theme.current) -bg.pressed $light
dict set vars(theme.dict) $vars(theme.current) -bg.active $light
dict set vars(theme.dict) $vars(theme.current) -bg.disabled $bg
if { [dict get $vars(theme.dict) $vars(theme.current) -border] eq "bg" } {
dict set vars(theme.dict) $vars(theme.current) -bordercolor $dark
dict set vars(theme.dict) $vars(theme.current) -bordercolor.pressed $dark
dict set vars(theme.dict) $vars(theme.current) -bordercolor.active $dark
dict set vars(theme.dict) $vars(theme.current) -bordercolor.disabled $dark
}
}
proc setTheme { } {
variable vars
set theme [string totitle [ttk::style theme use]]
set rc 0
# <<ThemeChanged>> 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
_initCommon $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 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})
}
if { $vars($self.-char) ne {} } {
${self}.cbchar configure \
-foreground $fg \
-background $bg
}
}
if { ! $vars(usespacer) } {
${self}.cbspacer2 configure \
-background $vars($self.-bg${suffix})
}
${self}.cbtext configure \
-foreground $vars($self.-fg${suffix}) \
-background $vars($self.-bg${suffix})
}
proc removeTrace { self } {
variable vars
if { [info exists vars($self.fqvn)] } {
trace remove variable $vars($self.fqvn) [list read write unset] \
[list ::checkButtonScaled::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 ::checkButtonScaled::traceTextVar $self]
}
try {
trace add variable $varnm unset \
[list ::checkButtonScaled::traceTextVar $self]
set vars($self.fqtvn) $varnm
} on error {err res} {
return 1
}
$self.cbtext configure -textvariable $vars($self.fqtvn)
return 0
}
return 1
}
proc configureVariable { self varnm } {
variable vars
if { ! [winfo exists $self] } {
return 1
}
try {
dict set vars($self.state) alternate 0
removeTrace $self
trace add variable $varnm [list read write unset] \
[list ::checkButtonScaled::traceVar $self]
if { [info exists vars($self.fqvn)] &&
$vars($self.-variable) eq $self &&
$varnm ne $vars($self.fqvn) &&
[info exists $vars($self.fqvn)] } {
unset $vars($self.fqvn) ; # clean up global namespace
}
set vars($self.fqvn) $varnm
} on error {err res} {
return 1
}
return 0
}
proc traceTextVar { self args } {
variable vars
lassign $args tvarnm nm2 type
if { $type eq "unset" } {
$self.cbtext configure -textvariable {}
set vars($self.-text) {}
set vars($self.-textvariable) {}
set vars($self.fqtvn) {}
unset -nocomplain $tvarnm
}
}
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
set vars($self.-variable) {}
set vars($self.fqvn) {}
unset -nocomplain tvarnm
} 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.fqvn)] && $vars($self.fqvn) ne {} } {
trace remove variable $vars($self.fqvn) [list read write unset] \
[list ::checkButtonScaled::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
::checkButtonScaled::widgetProcess $self state hover
}
}
proc leaveMain { self } {
variable vars
if { ! [dict get $vars($self.state) disabled] } {
dict set vars($self.state) hover 0
::checkButtonScaled::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
::checkButtonScaled::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
::checkButtonScaled::widgetProcess $self state {!active !hover}
}
}
proc toggle { self } {
variable vars
if { [dict get $vars($self.state) disabled] } {
return
}
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)
} else {
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 getFontSize { font } {
set a [font metrics $font -ascent]
# set d [font metrics $val -descent]
set l [font metrics $font -linespace]
set sz [expr {round($a-$l*0.1)}]
return $sz
}
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" } {
if { $val ne {} } {
set sz [getFontSize $val]
$self.cbindicator configure -height $sz -width $sz
if { $vars($self.-char) ne {} } {
$self.cbchar configure -font [createFont $sz]
}
}
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]
set tfocus [focus]
dict set vars($self.state) focus 0
if { [string match ${self}* $tfocus] } {
dict set vars($self.state) focus 1
}
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 {
if { [llength $args] == 1 } {
set arg [lindex $args 0]
if { [info exists vars($self.$arg)] } {
# option name, database name, database class,
# default value, curr value
return [list $arg [string trimleft $arg -] {} {} $vars($self.$arg)]
}
}
foreach {arg val} $args {
set arg [mapColorSpec $arg]
if { $arg eq "-checkchar" &&
$vars($self.-char) ne {} } {
$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
if { $vars($self.-char) ne {} } {
$self.cbchar configure -font [createFont $val]
}
}
if { $arg eq "-font" } {
set sz [getFontSize $val]
$self.cbindicator configure -height $sz -width $sz
if { $vars($self.-char) ne {} } {
$self.cbchar configure -font [createFont $sz]
}
}
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
if { $vars($self.-char) ne {} } {
$self.cbchar configure -cursor $val
}
$self.cbtext configure -cursor $val
if { ! $vars(usespacer) } {
$self.cbspacer2 configure -cursor $val
}
}
proc createFont { sz } {
variable vars
set sz [string trimright $sz p]
set sz [expr {$sz-($sz*0.2)}]
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
set vars($self.havelabel) 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
}
if { $vars($self.-textvariable) ne {} &&
[set $vars($self.fqtvn)] ne {} } {
set vars($self.havelabel) 1
}
if { $vars($self.-text) ne {} } {
set vars($self.havelabel) 1
}
if { $vars($self.-image) ne {} } {
set vars($self.havelabel) 1
}
# because mac os x has a large amount of extra whitespace
# attached to the label, pack and unpack the text label
# as needed.
if { ! $vars($self.havelabel) } {
if { ! $vars(usespacer) } {
pack forget $self.cbspacer2
}
pack forget $self.cbtext
} else {
if { ! $vars(usespacer) } {
pack $self.cbspacer2 -in $self \
-side left \
-ipadx 0 \
-ipady 1p
}
pack $self.cbtext -in $self \
-anchor $vars($self.-anchor) \
-side left \
-ipady 1p
if { ! $vars(usespacer) } {
pack configure $self.cbtext \
-ipadx 1p
}
}
} on error {err res} {
return -code error {widget has been destroyed}
}
return 0
}
proc configureLabel { self } {
variable vars
set cbtextargs [list \
-justify left \
-takefocus 0 \
-borderwidth 0 \
-highlightthickness 0 \
]
foreach {o} [list -font -height -underline] {
if { $vars($self.$o) ne {} } {
lappend cbtextargs $o $vars($self.$o)
}
}
set havelab 0
if { ! $vars($self.imageonly) } {
lappend cbtextargs -text $vars($self.-text)
if { $vars($self.-text) ne {} } {
set havelab 1
}
}
if { ! $vars($self.imageonly) && $vars($self.-textvariable) ne {} } {
lappend cbtextargs -textvariable $vars($self.fqtvn)
set havelab 1
}
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 checkButtonScaled { nm args } {
variable vars
set theme [string totitle [ttk::style theme use]]
if { $theme ne $vars(theme.current) } {
setTheme
}
set vars($nm.ns) [uplevel namespace current]
array set opts $args
# fedora 25 has a bug where 'Inf' is returned
# but once set is ok...
set tkscale [tk scaling]
if { $tkscale eq "Inf" } {
tk scaling -displayof . 1.3333
}
# 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.-value) 1
set vars($nm.-checkchar) {}
# 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 \
-highlightcolor -highlightthickness -highlightbackground \
-padx -pady -relief -style -takefocus \
-text -underline -value -variable \
] {
if { [info exists opts($o)] && $opts($o) ne {} } {
set vars($nm.$o) $opts($o)
}
}
set vars($nm.-char) $vars($nm.-checkchar)
if { $vars($nm.-font) eq {} } {
set sz [getFontSize TkDefaultFont]
} else {
set sz [getFontSize $vars($nm.-font)]
}
if { [info exists opts($nm.-indicatordiameter)] &&
$opts($nm.-indicatordiameter) ne {} } {
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) \
-takefocus $vars($nm.-takefocus) \
-highlightthickness 1 \
-highlightbackground $vars($nm.-bg) \
-highlightcolor $vars($nm.-highlightcolor)
# the indicator border
set bsz $vars($nm.-borderwidth)
frame ${nm}.cbouter \
-borderwidth ${bsz} \
-takefocus 0 \
-highlightthickness 0 \
-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 \
-takefocus 0 \
-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 \
-takefocus 0 \
-font [createFont $sz] \
-highlightthickness 0 \
-borderwidth 0
pack ${nm}.cbchar -in ${nm}.cbindicator \
-padx 0 -pady 0 -ipadx 0 -ipady 0
}
if { ! $vars(usespacer) } {
frame ${nm}.cbspacer2 \
-takefocus 0 \
-highlightthickness 0 \
-borderwidth 0 \
-width 0.25p
}
# labels on mac os x have a large amount of extra whitespace
label ${nm}.cbtext
if { $vars($nm.-style) ne {} } {
loadStyle $nm
}
rename $nm ::checkButtonScaled::$nm ; # main frame command
set vars($nm.aliastoken) [interp alias {} $nm {} \
::checkButtonScaled::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 <Destroy> \
+[list ::checkButtonScaled::selfdestroy $nm]
bind $nm <Enter> \
+[list ::checkButtonScaled::enterMain $nm]
bind $nm <Leave> \
+[list ::checkButtonScaled::leaveMain $nm]
bind $nm <space> \
+[list ::checkButtonScaled::toggle $nm]
bind $nm <ButtonPress-1> \
+[list ::checkButtonScaled::widgetProcess $nm state {active pressed}]
bind $nm <ButtonRelease-1> \
+[list ::checkButtonScaled::release $nm]
foreach {w} [list $nm.cbouter $nm.cbindicator $nm.cbchar \
$nm.cbspacer2 $nm.cbtext] {
if { ! [winfo exists $w] } {
continue
}
set taglist [bindtags $w]
bindtags $w [list $nm {*}$taglist]
bind $w <space> \
+[list ::checkButtonScaled::toggle $nm]
bind $w <Enter> \
+[list ::checkButtonScaled::enter $nm]
bind $w <Leave> \
+[list ::checkButtonScaled::leave $nm]
bind $w <ButtonPress-1> \
+[list ::checkButtonScaled::widgetProcess $nm state {active pressed}]
bind $w <ButtonRelease-1> \
+[list ::checkButtonScaled::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}
checkButtonScaled .cbon -variable on -text hello \
-command [list putstate .cbon]
checkButtonScaled .cbond -variable on -text hello
.cbond state disabled
checkButtonScaled .cbonr -variable on -text hello
.cbonr state readonly
checkButtonScaled .cboff -variable off -text hello \
-command [list putstate .cboff]
checkButtonScaled .cboffd -variable off -text hello
.cboffd state disabled
checkButtonScaled .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
checkButtonScaled .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
checkButtonScaled .cbonoffd -text disabled \
-command [list toggleState disabled]
pack .cbonoffd -side top -anchor w
checkButtonScaled .cbonoffa -text active \
-command [list toggleState active]
pack .cbonoffa -side top -anchor w
checkButtonScaled .cbonoffp -text pressed \
-command [list toggleState pressed]
pack .cbonoffp -side top -anchor w
checkButtonScaled .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 <Return> [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 <Return> [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 <Return> [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 <Return> [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 <Return> [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 <Return> [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 <Return> [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 <Return> [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 <Return> [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 <Return> [list setCompound]
pack .fk -side top -anchor w
pack .lk .ek -in .fk -side left -anchor w
update
after 5000 do5000
}
demo
}
package provide checkButtonScaled 1.20
