'''Current Version: 1.2''' [bll] 2018-8-16: A scalable radio button. It does not attempt to match the styling that the various available styles use. State handling is minimal. There are 8 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. [img-sradiobutton] <>Code ====== #!/usr/bin/tclsh # # Copyright 2018 Brad Lanam Walnut Creek, CA # package require Tk set ap [file dirname [info script]] if { $ap ni $::auto_path } { lappend ::auto_path $ap } unset ap package require colorutils proc sradiobutton { nm args } { srbwidget new $nm {*}$args return $nm } namespace eval ::srbcmd { variable vars proc handler { w args } { $w {*}$args } proc initializeAll { } { variable vars if { [info exists ::srbcmd::initialized] } { return } set ::srbcmd::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 SRadiobutton.TFrame \ -background $bg ttk::style configure SRadiobutton.TLabel \ -anchor e \ -width {} \ -background $bg \ -highlightthickness 0 ttk::style configure Indicator.SRadiobutton.TLabel \ -anchor {} } } ::oo::class create ::srbwidget { constructor { nm args } { my variable vars ::srbcmd::initializeAll set vars(ind.styles) { 1 {chars {\u25cb \u25cf} padding {0 0 0 3}} 2 {chars {\u25cc \u25cf} padding {0 0 0 3}} 3 {chars {\u26aa \u26ab} padding {0 0 0 0}} 4 {chars {\u25cb \u25c9} padding {0 0 0 3}} 5 {chars {\u25cc \u25c9} padding {0 0 0 3}} 6 {chars {\u25c7 \u25c6} padding {0 0 0 3}} 7 {chars {\u25c7 \u25c8} padding {0 0 0 3}} 8 {chars {\u2b26 \u2b25} padding {0 0 0 4}} } set vars(max.style) 8 set vars(char.nosel) \u25cb set vars(char.sel) \u25cf set vars(-indicatorstyle) 1 set vars(-indicatorcolor) {} set vars(-value) {} set vars(currvalue) {} set vars(char.disp) $vars(char.nosel) set vars(-command) {} set vars(font.basesize) 11 # some defaults set vars(frame.cont) [ttk::frame $nm \ -class Scaled.Radiobutton \ -style SRadiobutton.TFrame \ ] set vars(widget) [ttk::label $nm.indicator \ -style Indicator.SRadiobutton.TLabel \ -textvariable [self]::vars(char.disp) \ ] $vars(widget) configure -style 1.Indicator.SRadiobutton.TLabel set vars(label) [ttk::label ${nm}.label \ -style SRadiobutton.TLabel \ ] set vars(srb) ${nm}_srb rename $vars(frame.cont) ::$vars(srb) interp alias {} $vars(frame.cont) {} ::srbcmd::handler [self] uplevel 2 [list $vars(frame.cont) configure {*}$args] set vars(bind.tag) srbbt$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 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 } set k -variable set vars(currvalue) $vars(-value) if { [info exists vars($k)] } { set $vars($k) $vars(-value) } 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(-value) } { set vars(char.disp) $vars(char.sel); } else { set vars(char.disp) $vars(char.nosel); } } } 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 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 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]] } set nm $vars(label) return [uplevel 2 [list $nm {*}$args]] } method cget { key } { my variable vars set rv {} if { $key eq "-variable" || $key eq "-command" || $key eq "-indicatorcolor" || $key eq "-indicatorstyle" || $key eq "-value" } { 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.nosel) vars(char.sel) set style [$vars(label) cget -style] $vars(widget) configure -style $val.Indicator.$style } elseif { $key eq "-value" || $key eq "-command" || $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 sradiobutton 1.2 ====== <> <>Demo Code ====== package require Tk source code/sradiobutton.tcl proc p { x } { puts "cmd: $x" } font create eee font configure eee -size 28 set ::x B foreach {st} [list 1 2 3 4 5 6 7 8] { sradiobutton .sa$st -value A -variable ::x -text AAAA \ -indicatorstyle $st -command [list p e] sradiobutton .sb$st -value B -variable ::x -text BBBB \ -indicatorstyle $st -command [list p f] grid .sa$st .sb$st } set st 2 ttk::style configure B.SRadiobutton.TLabel -font eee sradiobutton .s1z -value E -variable ::z -text EE\ -indicatorstyle $st -command [list p e] -style B.SRadiobutton.TLabel sradiobutton .s2z -value F -variable ::z -text FF \ -indicatorstyle $st -command [list p f] -style B.SRadiobutton.TLabel set ::z F grid .s1z .s2z font create fff font configure fff -size 13 ttk::style configure C.SRadiobutton.TLabel -font fff sradiobutton .s1w -value E -variable ::z -text GG \ -indicatorstyle $st -command [list p e] -indicatorcolor blue \ -style C.SRadiobutton.TLabel sradiobutton .s2w -value F -variable ::z -text HH \ -indicatorstyle $st -command [list p f] -indicatorcolor blue \ -style C.SRadiobutton.TLabel grid .s1w .s2w ====== <>