JOB - 2017-02-02 20:36:26If someone is missing the -resolution option for the ttk::scale widget...
I also noticed that there is a small missbehavior in the ttk::scale binding declarations (tcl/tk8.6). See extra binding in the code below (Build method) which fixes this issue.
In the hope, that it will be useful, here is the code:
# -----------------------------------------------------------------------------
# xscale.tcl ---
# -----------------------------------------------------------------------------
# (c) 2017, Johann Oberdorfer - Engineering Support | CAD | Software
# johann.oberdorfer [at] gmail.com
# www.johann-oberdorfer.eu
# -----------------------------------------------------------------------------
# This source file is distributed under the BSD license.
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
# See the BSD License for more details.
# -----------------------------------------------------------------------------
# Purpose:
# A TclOO class template to extend ttk::scale functionality.
# Same behavior as tk::scale widget,
# implements -resolution option.
# -----------------------------------------------------------------------------
# http://wiki.tcl.tk/40210
# derived from ttk::scale, implements -resolution found in older scale
package provide xscale 0.1
namespace eval xscale {
variable cnt 0
# this is a tk-like wrapper around my... class so that
# object creation works like other tk widgets
proc xscale {path args} {
variable cnt
incr cnt
set obj [XScaleClass create tmp${cnt} $path {*}$args]
# rename oldName newName
rename $obj ::$path
return $path
}
oo::class create XScaleClass {
constructor { path args } {
my variable widgetOptions
my variable oldval
my variable label_txt
set label_txt ""
array set widgetOptions {
-resolution 1.0
-command ""
-showvalue 0
-compound "right"
}
# incorporate arguments to local widget options
array set widgetOptions $args
# we use a frame for this specific widget class
set f [ttk::frame $path -class xscale]
# we must rename the widget command
# since it clashes with the object being created
set widget ${path}_
my Build $f
rename $path $widget
my configure {*}$args
}
# add a destructor to clean up the widget
destructor {
set w [namespace tail [self]]
catch {bind $w <Destroy> {}}
catch {destroy $w}
}
method cget { {opt "" } } {
my variable scalewidget
my variable widgetOptions
if { [string length $opt] == 0 } {
return [array get widgetOptions]
}
if { [info exists widgetOptions($opt) ] } {
return $widgetOptions($opt)
}
return [$scalewidget cget $opt]
}
method configure { args } {
my variable scalewidget
my variable widgetOptions
my variable label_txt
if {[llength $args] == 0} {
# return all tablelist options
set opt_list [$scalewidget configure]
# as well as all custom options
foreach xopt [array get widgetOptions] {
lappend opt_list $xopt
}
return $opt_list
} elseif {[llength $args] == 1} {
# return configuration value for this option
set opt $args
if { [info exists widgetOptions($opt) ] } {
return $widgetOptions($opt)
}
return [$scalewidget cget $opt]
}
# error checking
if {[expr {[llength $args]%2}] == 1} {
return -code error "value for \"[lindex $args end]\" missing"
}
# process the new configuration options...
array set opts $args
foreach opt_name [array names opts] {
set opt_value $opts($opt_name)
# overwrite with new value
if { [info exists widgetOptions($opt_name)] } {
set widgetOptions($opt_name) $opt_value
}
# some options need action from the widgets side
switch -- $opt_name {
-resolution {
set widgetOptions(-resolution) $opt_value
}
-variable {
my SetVariable $opt_value
my ShowValue
}
-command {
# not allowed to overwrite our own command
# procedure as it triggers the "hopping" behavior
# use the variable to get the actual scale value
set cmd $opt_value
append cmd "; [namespace code {my ResolutionCmd}]"
$scalewidget configure -command $cmd
}
-showvalue {
# immediately show or hide the actual value...
set widgetOptions(-showvalue) $opt_value
my ShowValue
}
-value {
# overwrite existing option!
return -code error \
"option -value is not supported, use -variable instead!"
}
-compound {
# static declaration for the moment
}
default {
# -------------------------------------------------------
# if the configure option wasn't one of our special one's,
# pass control over to the original ttk::scale widget
# -------------------------------------------------------
# puts ">>> $opt_name : $opt_value"
if {[catch {$scalewidget configure $opt_name $opt_value} result]} {
return -code error $result
}
}
}
}
}
# --------------------------------------------------
# if the command wasn't one of our special one's,
# pass control over to the original tablelist widget
# --------------------------------------------------
method unknown {method args} {
my variable scalewidget
if {[catch {$scalewidget $method {*}$args} result]} {
return -code error $result
}
return $result
}
method ShowValue { } {
my variable scalewidget
my variable widgetOptions
my variable label_txt
if {$widgetOptions(-showvalue) == 0} {
set label_txt ""
} else {
set label_txt [$scalewidget cget -value]
}
}
method SetVariable { varname } {
my variable scalewidget
my variable widgetOptions
set widgetOptions(-variable) $varname
$scalewidget configure -variable $varname
if { $varname ne {} } {
upvar #0 $varname tracevar
if { ![info exists tracevar] } {
set tracevar [$scalewidget cget -from]
}
set oldval $tracevar
}
}
method ResolutionCmd { val } {
my variable widgetOptions
my variable oldval
my variable label_txt
# round value to nearest multiple of resolution
set res $widgetOptions(-resolution)
set hopval [expr {$res * floor(double($val) / $res + 0.5)}]
if { $widgetOptions(-variable) ne {} } {
upvar #0 $widgetOptions(-variable) var
set var $hopval
}
# run callback as in standard scale
# only for a different value == integer hop
if { $hopval != $oldval } {
set oldval $hopval
if { $widgetOptions(-command) ne {} } {
set command_with_value [linsert $widgetOptions(-command) end $hopval]
uplevel #0 $command_with_value
}
}
# round the return value !
set hopval [expr {double(round(100*$hopval))/100}]
# puts "hopval: $hopval"
if {$widgetOptions(-showvalue) == 1} {
set label_txt $hopval
}
return $hopval
}
method Build {win} {
my variable scalewidget
my variable widgetOptions
my variable oldval
my variable label_txt
ttk::label $win.lbl \
-textvariable "[namespace current]::label_txt"
ttk::scale $win.sc \
-command "[namespace code {my ResolutionCmd}]"
# compound left:
# pack $win.lbl -side left
# pack $win.sc -side right -fill x -expand true
# compound right (default)
pack $win.sc -side left -fill x -expand true
pack $win.lbl -side right
set scalewidget $win.sc
set oldval [$scalewidget cget -value]
# need to overwrite the ttk binding:
# note:
# the original bindings in the tcl distribution
# uses "Press" instead of "Jump" which, when clicking
# with the mouse, has no effect!
#
bind TScale <ButtonPress-1> { ttk::scale::Jump %W %x %y }
}
}
}
xcale_test.tcl
#
# xscale test
#
set dir [file dirname [info script]]
set auto_path [linsert $auto_path 0 [file join $dir "."]]
package require Tk
package require xscale 0.1
# ---test ---
catch {console show}
proc echo1 {args} {
global test1
puts "echo1: $test1"
}
proc echo2 {args} {
puts "echo2: $args"
}
set top [toplevel .test]
$top configure -bg [ttk::style lookup TLabel -background]
wm withdraw .
wm geometry $top "400x200"
# --- S C A L E
label $top.scale -text "tk::scale:"
pack $top.scale
set test1 8
scale $top.scl \
-orient "horizontal" \
-from -10 -to 10 -resolution 2.0 \
-variable test1 \
-command echo1 \
-showvalue 1
pack $top.scl -expand yes -fill x
# --- TTK :: S C A L E
label $top.ttkscale -text "ttk::scale:"
pack $top.ttkscale
set test2 8
ttk::scale $top.scl0 \
-from -10 -to 10 \
-variable test2 \
-command echo2 \
-value 8
pack $top.scl0 -expand yes -fill x
# --- X S C A L E
label $top.xscale -text "xscale:"
pack $top.xscale
set test3 8
xscale::xscale $top.scl1 \
-from -10 \
-to 10 \
-resolution 2.0 \
-variable test3 \
-command echo2 \
-showvalue 1 \
-compound "right"
pack $top.scl1 -expand yes -fill x
set test4 10
xscale::xscale $top.scl2 \
-from 0 -to 40 -resolution 2.0 \
-variable test4 \
-command echo2 \
-showvalue 1
pack $top.scl2 -expand yes -fill x
