The code below is a further improvement from a meter that originally appeared on the french wiki [L1 ]. I modified it twice to suit my needs and ended up feeling that it would perhaps benefit to a larger audience if posted here. Check out the original page for some screen dumps. Apart from some bug fixing, I have added two features to the original code:
The honour is not mine, I am only an humble modifier. EF
if {[info exists ::meter::version]} { return }
namespace eval ::meter {
# beginning of ::meter namespace definition
# ####################################
#
# meter widget
#
variable version 1.2
#
# ulis, (C) 2005
# Emmanuel Frecon, (C) 2006
#
# ------------------------------------
# ####################################
# ==========================
#
# package
#
# ==========================
package provide ASimpleMeter $version
package require Tk
# ====================
#
# entry point
#
# ====================
namespace export meter
# ====================
#
# global variables. Current recognised options for a meter
# widget are the following:
#
# -bd is the border around the meter
# -bg is the color to use for the background
# -cmd is a command that can periodically be called to update the
# value of a meter widget. Any occurence of the string %widget%
# will be replaced by the path to the widget.
# -gcolor is the color of the meter gauge background
# -font is the font to use when showing meter values
# -height is the height of the widget
# -max is the maximum value represented by the meter
# -min is the minimum value represented by the meter
# -maxcolor is the color of the maximum needle, empty to disable.
# -mincolor is the color of the minimum needle, empty to disable.
# -mcolor is the color of the min/max text labels.
# -ncolor is the color of the main needle.
# -relief is the relief of the widget
# -sections is a list of sections on the gauge display. Each
# section is a list with the value at which it starts, its amount
# (in value space) and its color.
# -showval is a boolean telling whether to show labels on the meter or not
# -vcolor is the color of the current meter label value, when appropriate
# -width is the width of the meter
#
# ====================
variable {}
array set {} {
-bd 1
-bg ""
-cmd ""
-delay 100
-gcolor green
-font "Helvetica 8"
-height 50
-max 100
-maxcolor blue
-mincolor blue
-mcolor grey75
-min 0
-ncolor orange
-relief groove
-sections {{75 25 red}}
-showval on
-vcolor black
-width 100
}
}
# ::meter::meter -- Create, get or set options
#
# This procedure is able to either set or get the default
# options for the meter module, or to create a new meter,
# depending on its arguments.
#
# Arguments:
# args get as a first argument to get a default option, set to set it,
# otherwise the name of a widget followed by its options.
#
# Results:
# Return the value of the option or the name of the widget,
# depending on the "mode" of the command.
#
# Side Effects:
# None.
proc ::meter::meter {args} {
set rc [catch {
set cmd [lindex $args 0]
switch -glob -- -$cmd {
-get { return [uplevel 1 ::meter::meter:dget $args] }
-set { return [uplevel 1 ::meter::meter:dset $args] }
default {
if {[string index $cmd 0] != "."} {
error "use is 'meter path options' or 'meter set options'\
or 'meter get key'"
}
return [uplevel 1 ::meter::meter:create $args]
}
}
} msg]
if {$rc == 1} { return -code error $msg } else { return $msg }
}
# ::meter::meter:dget -- Get default options
#
# This procedure will get one of the default options for all
# widgets that will be created in the near future.
#
# Arguments:
# get Unused
# args Only the first argument is used, one dash-led option
#
# Results:
# Return the value of the option or an error
#
# Side Effects:
# None.
proc ::meter::meter:dget {get args} {
variable {}
if {[llength $args] != 1} {
return -code error "use is 'meter get key'"
}
set key [lindex $args 0]
switch -glob -- $key {
-bg -
-bac* { set (-bg) }
-bd -
-bor* { set (-bd) }
-cmd -
-com* { set (-command) }
-del* { set (-delay) }
-fon* { set (-font) }
-gco* { set (-gcolor) }
-hei* { set (-height) }
-max { set (-max) }
-maxco* { set (-maxcolor) }
-minco* { set (-mincolor) }
-mco* { set (-mcolor) }
-min* { set (-min) }
-nco* { set (-ncolor) }
-rel* { set (-relief) }
-sec* { set (-sections) }
-sho* { set (-showval) }
-vco* { set (-vcolor) }
-wid* { set (-width) }
default { error "unknown meter default option '$key'" }
}
}
# ::meter::meter:set -- Set a default option
#
# This procedure will set one or several default options for all
# widgets that will be created in the future.
#
# Arguments:
# set Unused
# args List of option values pairs, options are dash-led
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::meter::meter:dset {set args} {
variable {}
if {[llength $args] % 2 != 0} {
error "use is 'meter set \[key value]...'"
}
foreach {key value} $args {
switch -glob -- $key {
-bg -
-bac* { set (-bg) $value }
-bd -
-bor* { set (-bd) $value }
-cmd -
-com* { set (-command) $value }
-del* { set (-delay) $value }
-fon* { set (-font) $value }
-gco* { set (-gcolor) $value }
-hei* { set (-height) $value }
-max { set (-max) $value }
-maxco* { set (-maxcolor) $value }
-minco* { set (-mincolor) $value }
-mco* { set (-mcolor) $value }
-min* { set (-min) $value }
-nco* { set (-ncolor) $value }
-rel* { set (-relief) $value }
-sec* { set (-sections) $value }
-sho* { set (-showval) $value }
-vco* { set (-vcolor) $value }
-wid* { set (-width) $value }
default { error "unknown meter default option '$key'" }
}
}
}
# ::modname::meter:create -- Create a new meter
#
# This procedure will create a new meter which Tk path is given
# as a first argument. This is a pseudo-widget and the
# procedure also creates a command under the name of the widget
# to operate on the widget, as is usual with Tk.
#
# Arguments:
# w Full Tk path to widget
# args List of option values pairs, options are dash-led
#
# Results:
# Return the Tk path to the widget (its name!)
#
# Side Effects:
# None.
proc ::meter::meter:create {w args} {
variable {}
# initial options
set initial [list]
foreach key [array names {} -*] {
lappend initial $key $($key)
}
# create canvas
canvas $w -highlightt 1
set bg [$w cget -bg]
$w create arc 0 0 0 0 -start 20 -extent 140 \
-style pie -tags [list gauge meter]
$w create arc 0 0 0 0 -start 0 -extent 180 \
-style pie -fill $bg -outline "" -tags bottom
$w create arc 0 0 0 0 -extent 0 -width 2 -start 160 \
-style pie -tags needle
$w create arc 0 0 0 0 -extent 0 -width 1 -start 20 \
-style pie -tags minneedle -state hidden
$w create arc 0 0 0 0 -extent 0 -width 1 -start 160 \
-style pie -tags maxneedle -state hidden
$w create text 0 0 -text "" -tags min
$w create text 0 0 -text "" -tags max
$w create text 0 0 -text "" -tags value
$w raise maxneedle
$w raise minneedle
$w raise needle
$w raise bottom
# build reference
rename $w ::meter::_$w
interp alias {} ::$w {} ::meter::meter:dispatch $w
# set options
meter:stop $w
if {$initial != ""} { uplevel 1 ::meter::meter:config $w $initial }
if {$args != ""} { uplevel 1 ::meter::meter:config $w $args }
# return reference
return $w
}
# ::meter::meter:dispatch -- Dispatch meter operations
#
# This procedure dispatch further operations on a meter widget
# that has previously been created. The procedure implements
# the command that is associated to the widget. The commands
# that are implemented by the meter are cget, configure, get,
# getall, invoke, set, start, stop, reset. Other commands are
# blindly passed further to the canvas that implements the
# widget.
#
# Arguments:
# w Full Tk path to the widget
# args Operation to perform and its arguments.
#
# Results:
# None
#
# Side Effects:
# None.
proc ::meter::meter:dispatch {w args} {
set cmd [lindex $args 0]
set args [lrange $args 1 end]
set rc [catch {
switch -glob -- -$cmd {
-cge* { return [uplevel 1 ::meter::meter:cget $w $args] }
-con* { return [uplevel 1 ::meter::meter:config $w $args] }
-get { return [uplevel 1 ::meter::meter:vget $w $args] }
-getall { return [uplevel 1 ::meter::meter:getall $w $args] }
-reset { return [uplevel 1 ::meter::meter:reset $w $args] }
-inv* { return [uplevel 1 ::meter::meter:invoke $w $args] }
-set { return [uplevel 1 ::meter::meter:vset $w $args] }
-sta* { return [uplevel 1 ::meter::meter:start $w $args] }
-sto* { return [uplevel 1 ::meter::meter:stop $w $args] }
default { return [uplevel 1 ::meter::_$w $cmd $args] }
}
} msg]
if {$rc == 1} { return -code error $msg } else { return $msg }
}
# ::meter::meter:cget -- Get a widget option
#
# This procedure retreives an options that has been set for a
# given meter widget.
#
# Arguments:
# w Full Tk path to the widget
# args Dash-led option to be retrieved.
#
# Results:
# Return the value of the option or an error on unknown options.
#
# Side Effects:
# None.
proc ::meter::meter:cget {w args} {
variable {}
if {[llength $args] != 1} {
error "use is 'path cget key'"
}
set _w ::meter::_$w
set key [lindex $args 0]
switch -glob -- $key {
-cmd -
-com* { set ($w:-command) }
-del* { set ($w:-delay) }
-gco* { set ($w:-gcolor) }
-fon* { set ($w:-font) }
-max { set ($w:-max) }
-maxco* { set ($w:-maxcolor) }
-minco* { set ($w:-mincolor) }
-mco* { set ($w:-mcolor) }
-min* { set ($w:-min) }
-nco* { set ($w:-ncolor) }
-sec* { set ($w:-sections) }
-sho* { set ($w:-showval) }
-vco* { set ($w:-vcolor) }
-var* {
set rc [catch { set ($w:-variable) }]
if {$rc == 1} {
error "meter option -variable value is not defined"
}
}
default { $_w cget $key }
}
}
# ::meter::meter:config -- (re)configure a meter
#
# This procedure (re)configure a widget that has previously been
# created. The new values for the options that are passed in
# the parameters are taken into account and the appearance
# and/or behaviour of the meter is modified accordingly.
#
# Arguments:
# w Full Tk path to the widget
# args New dash-led option and value pairs.
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::meter::meter:config {w args} {
variable {}
if {[llength $args] % 2 != 0} {
error "use is 'path config \[key value]...'"
}
set _w ::meter::_$w
set cflag 0
set sflag 0
foreach {key value} $args {
switch -glob -- $key {
-bg -
-bac* {
if {$value == ""} { set value [$_w cget -bg] }
$_w config $key $value
$_w itemconfig bottom -fill $value
}
-hei* -
-wid* { $_w config $key $value; set sflag 1 }
-cmd -
-com* { set ($w:-command) $value }
-del* { set ($w:-delay) $value }
-gco* {
set ($w:-gcolor) $value
$_w itemconfig gauge -fill $value -outline $value
}
-fon* {
set ($w:-font) $value
$_w itemconfigure min -font $value -justify left -anchor e
$_w itemconfigure max -font $value -justify right -anchor w
$_w itemconfigure value -font $value -justify center \
-anchor center
}
-max { set ($w:-max) $value; set cflag 1 }
-maxco* { set ($w:-maxcolor) $value; set cflag 1 }
-minco* { set ($w:-mincolor) $value; set cflag 1 }
-min* { set ($w:-min) $value; set cflag 1 }
-mco* {
set ($w:-mcolor) $value
$_w itemconfigure min -fill $value
$_w itemconfigure max -fill $value
}
-nco* {
set ($w:-ncolor) $value
$_w itemconfig needle -fill $value -outline $value
}
-sec* { set ($w:-sections) $value; set sflag 1 }
-sho* { set ($w:-showval) $value; set sflag 1 }
-var* {
set ($w:-variable) $value
trace add variable $value write [list ::meter::meter:change $w]
}
-vco* {
set ($w:-vcolor) $value
$_w itemconfigure value -fill $value
}
default { $_w config $key $value }
}
}
if {$cflag} {
set ($w:coef) [expr {140.0 / ($($w:-max) - $($w:-min))}]
}
if {$cflag || $sflag} {
$_w delete section
set width [$_w cget -width]
set height [$_w cget -height]
set coef $($w:coef)
set xb0 0
set xb1 [expr {$width * 0.500}]
set yb0 0
set yb1 [expr {$height * 1.000}]
$_w coords bottom $xb0 $yb0 $xb1 $yb1
set xt0 0
set xt1 [expr {$width * 0.800}]
set yt0 0
set yt1 [expr {$height * 1.600}]
$_w coords gauge $xt0 $yt0 $xt1 $yt1
$_w coords needle $xt0 $yt0 $xt1 $yt1
$_w coords minneedle $xt0 $yt0 $xt1 $yt1
$_w coords maxneedle $xt0 $yt0 $xt1 $yt1
foreach section $($w:-sections) {
foreach {start extent color} $section {
set start [expr {160 - ($start + $extent - $($w:-min)) * $coef}]
set extent [expr {$extent * $coef}]
$_w create arc $xt0 $yt0 $xt1 $yt1 \
-start $start -extent $extent -style pie \
-fill $color -outline $color -tags [list section meter]
}
}
$_w move meter [expr {$width * 0.100}] [expr {$height * 0.200}]
$_w move needle [expr {$width * 0.100}] [expr {$height * 0.200}]
$_w move minneedle [expr {$width * 0.100}] [expr {$height * 0.200}]
$_w move maxneedle [expr {$width * 0.100}] [expr {$height * 0.200}]
$_w move bottom [expr {$width * 0.250}] [expr {$height * 0.500}]
$_w raise minneedle
$_w raise maxneedle
$_w raise needle
$_w raise bottom
if { $($w:-maxcolor) eq "" } {
$_w itemconfigure maxneedle -state hidden
} else {
$_w itemconfigure maxneedle -state normal -fill $($w:-maxcolor) \
-outline $($w:-maxcolor)
}
if { $($w:-mincolor) eq "" } {
$_w itemconfigure minneedle -state hidden
} else {
$_w itemconfigure minneedle -state normal -fill $($w:-mincolor) \
-outline $($w:-mincolor)
}
if { [string is true $($w:-showval)] } {
$_w coords min [expr {0.2*$width}] [expr {0.9*$height}]
$_w coords max [expr {0.8*$width}] [expr {0.9*$height}]
$_w coords value [expr {0.5*$width}] [expr {0.85*$height}]
$_w itemconfigure min -text $($w:-min)
$_w itemconfigure max -text $($w:-max)
$_w itemconfigure value -text "?"
foreach i [list min max value] {
$_w itemconfigure $i -state normal
$_w raise $i
}
} else {
foreach i [list min max value] {
$_w itemconfigure $i -state hidden
}
}
}
}
# ::meter::meter:vget -- Get meter value
#
# This procedure actively computes the current value of a meter.
#
# Arguments:
# w Full Tk path to the widget
#
# Results:
# Value of the meter
#
# Side Effects:
# None.
proc ::meter::meter:vget {w} {
return [lindex [meter:getall $w] 1]
}
# ::meter::meter:getall -- Get meter value and min/max
#
# This procedure actively computes the current value of a meter,
# as well as the minimum and maximum that it has reached since
# it was started.
#
# Arguments:
# w Full Tk path to the widget
#
# Results:
# A list composed of the minimum since start, the current value,
# and the maximum.
#
# Side Effects:
# None.
proc ::meter::meter:getall {w} {
variable {}
set _w ::meter::_$w
set mincurrent [$_w itemcget minneedle -start]
set current [$_w itemcget needle -start]
set maxcurrent [$_w itemcget maxneedle -start]
return [list \
[expr {(160-$mincurrent) / $($w:coef)}] \
[expr {(160-$current) / $($w:coef)}] \
[expr {(160-$maxcurrent) / $($w:coef)}]]
}
# ::meter::meter:needleset -- Set a needle to a value
#
# This procedure moves an existing widget needle to a given value
#
# Arguments:
# w Full Tk path to the widget
# needle Tag of needle to move
# value Value to show
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::meter::meter:needleset {w needle value} {
variable {}
set _w ::meter::_$w
set angle [expr 160 - ($($w:coef) * $value)]
$_w itemconfig $needle -start $angle
}
# ::meter::meter:vset -- Set meter value
#
# This procedure sets the current value shown by the meter and
# automatically registers and updates the minimum and maximum
# values that are associated to the meter.
#
# Arguments:
# w Full Tk path to the widget
# value New value to be shown.
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::meter::meter:vset {w value} {
variable {}
# Get current minimum and maximum and update their needles (and
# underlying values) if necessary.
foreach {min v max} [meter:getall $w] break
if { $value > $max } { meter:needleset $w maxneedle $value }
if { $value < $min } { meter:needleset $w minneedle $value }
# Set main needle in place.
meter:needleset $w needle $value
# Update the text shown.
set _w ::meter::_$w
$_w itemconfig value -text $value
}
# ::meter::meter:reset -- Reset min/max
#
# This procedure will reset the minimum and maximum for the
# widget.
#
# Arguments:
# w Full Tk path to the widget
#
# Results:
# None
#
# Side Effects:
# None.
proc ::meter::meter:reset {w} {
variable {}
set _w ::meter::_$w
$_w itemconfigure minneedle -start 20
$_w itemconfigure maxneedle -start 160
}
# ::meter::meter:change -- Set value on variable changes
#
# This procedure is a trace callback that sees to automatically
# update the meter whenever the variable that it is associated
# to changes.
#
# Arguments:
# w Full Tk path to the widget
# args Unused
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::meter::meter:change {w args} {
variable {}
::meter::meter:vset $w [set $($w:-variable)]
}
# ::meter::meter:stop -- Stop meter
#
# This procedure stops a given meter to periodically updates
# itself.
#
# Arguments:
# w Full Tk path to the widget
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::meter::meter:stop {w} {
variable {}
set ($w:stop) 1
}
# ::meter::meter:start -- Start meter
#
# This procedure starts a given meter to periodically updates
# itself.
#
# Arguments:
# w Full Tk path to the widget
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::meter::meter:start {w} {
variable {}
set ($w:stop) 0
meter:invoke $w
}
# ::meter::meter:invoke -- Invoke bound command
#
# This procedure automatically invoke the command that can be
# associated to a meter so that it will periodically updates
# itself.
#
# Arguments:
# w Full Tk path to the widget
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::meter::meter:invoke {w} {
variable {}
if {$($w:stop)} { return }
set script $($w:-command)
if {$script != ""} {
set map [list %widget% $w]
eval [string map $map $script]
}
after $($w:-delay) ::meter::meter:invoke $w
}
namespace import ::meter::meter