poor man's progressbar
Brett Schwarz: So, you want a progressbar, but don't want to load an external package (ok, I am digging here :) ).
Well, you can get a basic progressbar by just re-using the scale widget. Here is an example:
ulis, 2005-03-19: See at the bottom for a minimal canvas solution (with about 6 commands).
scale .sc \
-orient horizontal \
-sliderrelief flat \
-sliderlength 0 \
-troughcolor #AAAAAA \
-showvalue 0 \
-label 0Notice the relief is flat. You could use another relief, but the results aren't as good. We set sliderlength to 0, so initially, nothing is shown. We will take advantage of the sliderlength to actually animate the progressbar.
march, 2005-09-22 ... to avoid mouse-interaction, this helps: -state disabled
Here is a proc that could be used to move the progressbar:
proc setpb {value} {
.sc configure \
-sliderlength [expr {$value - 3}] \
-label $value
return
}The $value - 3 is just a fudge factor to make it look nicer when display (on Linux running 8.4.4). So, an example of the usage would be:
proc go {} {
for {set i 5} {$i <= 80} {incr i 5} {
setpb $i
update idletasks
after 50
}
}
button .go -text go -command goYou can also take advantage of a 'quirk' in the scale code, and use -activebackground along with -state option to change the color of the progressbar. So, it would look like this then:
scale .sc \
-orient horizontal \
-sliderrelief flat \
-sliderlength 0 \
-troughcolor #AAAAAA \
-showvalue 0 \
-label 0 \
-activebackground blue \
-state active
pack .sc .goThere is no option to position the counter, so you are stuck with the default. Also, if the -orient is vertical, the progressbar goes from top to bottom.
There is one catch to this last incarnation -- if the mouse moves over the slider and then back again, then the color of the slider changes to the background color of the widget.
I also noticed on Windows that when you click on the slider, the -relief changes to raised... I think this is probably a bug???
And this is what it would look like:
broken image removed (Image link broken 1/1/2013)
PT 14-Aug-2003: The relief changing bug was fixed in 8.4.4. For the other quirks you should play with the bindings. For instance:
bind .sc <Enter> {break}
bind .sc <Leave> {break}
bind .sc <Motion> {break}
bind .sc <1> {break}
bind .sc <ButtonRelease-1> {break}serves to make this pretty inactive and eliminates the colour change when the mouse passes over the widget. Better still is the use of the bindtags command:
bindtags .sc [list .sc]
This will allow for custom bindings to this particular widget but ignores any default bindings from classes and such.
MGS [2003/08/19] - Here's a slightly more complete version, to allow for different -borderwith and -highlightthickness settings, and for dynamic resizing.
# progress.tcl --
# A simple progress meter using a Tk scale widget.
# ======================================================================
proc progress {W args} {
array set map [list \
-bd -borderwidth \
-bg -background \
]
array set arg [list \
-activebackground blue \
-borderwidth 1 \
-from 0 \
-to 100 \
-orient horizontal \
-sliderrelief flat \
-sliderlength 0 \
-troughcolor #AAAAAA \
-showvalue 0 \
-label 0 \
-state active \
]
foreach {option value} $args {
if { [info exists map($option)] } { set option $map($option) }
set arg($option) $value
}
eval [linsert [array get arg] 0 scale $W]
bind $W <Enter> {break}
bind $W <Leave> {break}
bind $W <Motion> {break}
bind $W <1> {break}
bind $W <ButtonRelease-1> {break}
bind $W <Configure> [list [namespace current]::progress:redraw %W]
return $W
}
# ======================================================================
proc progress:redraw {W} {
set value [$W cget -label]
set bd [$W cget -bd]
set ht [$W cget -highlightthickness]
set from [$W cget -from]
set to [$W cget -to]
set w [winfo width $W]
set tw [expr {$w - (4 * $bd) - (2 * $ht)}]
set range [expr {$to - $from}]
set pc [expr {($value - $from) * 1.0 / $range}]
set sl [expr {round($pc * $tw)}]
$W configure -sliderlength $sl
return
}
# ======================================================================
proc progress:set {W value} {
$W configure -label $value
progress:redraw $W
return
}
# ======================================================================
proc go {W value} {
progress:set $W $value
incr value
if { $value <= 75 } {
after 50 [list go $W $value]
}
}
if { [info exists argv0] && [string equal [info script] $argv0] } {
progress .sc
button .go -text go -default active \
-command [list [namespace current]::go .sc 0]
pack .sc -side top -expand 1 -fill both
pack .go -side bottom -expand 0 -fill none -anchor se
}EF Well, for some reason, on Tcl/Tk 8.4.13, the code above will insist in showing the label even though the code says -showvalue off (which should turn this off!). My new code below is mis-using another parameter that is of no interest for a progress bar, i.e. the resolution. My implementation stores the value as minus the resolution, which has no effect on the scale and effectively stores the value. Except from that, the code is identical. I have not dared changing the original code above since I am unsure whether what I discovered is a bug or a documented feature.
proc progressbar {W args} {
array set map [list \
-bd -borderwidth \
-bg -background \
]
array set arg [list \
-activebackground blue \
-borderwidth 1 \
-from 0 \
-to 100 \
-orient horizontal \
-sliderrelief flat \
-sliderlength 0 \
-troughcolor #AAAAAA \
-showvalue 0 \
-state active \
]
foreach {option value} $args {
if { [info exists map($option)] } { set option $map($option) }
set arg($option) $value
}
set arg(-resolution) [expr -$arg(-from)]
eval [linsert [array get arg] 0 scale $W]
bind $W <Enter> {break}
bind $W <Leave> {break}
bind $W <Motion> {break}
bind $W <1> {break}
bind $W <ButtonRelease-1> {break}
bind $W <Configure> [list [namespace current]::progressbar:redraw %W]
return $W
}
proc progressbar:redraw {W} {
set value [expr -[$W cget -resolution]]
set bd [$W cget -bd]
set ht [$W cget -highlightthickness]
set from [$W cget -from]
set to [$W cget -to]
set w [winfo width $W]
set tw [expr {$w - (4 * $bd) - (2 * $ht)}]
set range [expr {$to - $from}]
set pc [expr {($value - $from) * 1.0 / $range}]
set sl [expr {round($pc * $tw)}]
$W configure -sliderlength $sl
}
proc progressbar:set {W value} {
$W configure -resolution [expr -$value]
[namespace current]::progressbar:redraw $W
}Canvas solutions
# build
package require Tk
canvas .c -width 200 -height 20 -bd 1 -relief groove -highlightt 0
.c create rectangle 0 0 0 20 -tags bar -fill navy
proc run {percent} { .c coords bar 0 0 [expr {int($percent * 2)}] 20 }
pack .c -padx 10 -pady 10
# run
focus -force .c
raise .c
for {set i 0} {$i < 100} {incr i} \
{
run $i
after 100
update
}rdt Please help me out, here. I see "... -bd 1 -relief groove". But the picture seems to be a "... -bd 1 -relief sunken". Does groove appear the same if the border is only 1?
EKB Apparently so, at least on my Windows XP machine. I get the same effect with either -bd 1 -relief groove or -bd 1 -relief sunken. Setting -bd to 2 gives the expected effect.
MG sees a barely noticeable difference with groove and sunken, when -bd is set to 1 - sunken's border appears slightly darker than groove's. With -bd 2 the difference becomes more noticeable and expected.
# build
canvas .c -width 50 -height 50 -highlightt 0
.c create oval 2 2 48 48 -tags t1 -fill red -outline ""
.c create arc 2 2 48 48 -tags t2 -fill green -extent 0 -outline ""
.c create text 25 25 -tags t3
pack .c -padx 60 -pady 5
proc run {percent} \
{
.c itemconfig t3 -text $percent%
.c itemconfig t2 -extent [expr {round($percent * 3.6)}]
}
# run
focus -force .c
raise .c
for {set i 0} {$i <= 100} {incr i} \
{
run $i
after 100
update
}
.c itemconfig t1 -fill greenProcess Bar for External Process
What do you do if you have an external non-tcl process that is time-consuming and needs a progress bar? You have no access to the internals.
The basic idea is to start the process in the background. When you start the process, get the process ID.
Then check the process ID in a loop, updating a progress bar with each loop iteration. When the process ID disappears, the process is done and you continue on.
Here's some example code:
# Create the command. 'convert' is from the Imagemagick suite of
# image processing commands.
set convertCommand "convert foo.tiff foo.txt &"
set PIDconvert [eval $convertCommand]
puts "PIDconvert: $PIDconvert"
# Create the progress bar in a toplevel
# createProgressBar shown below.
createProgressBar green
set loopCounter 0
set maxLoopCounter 400.0
while { 1 } {
incr loopCounter
set catchVar [ catch {set ps [exec /bin/ps $PIDconvert]}]
if {$catchVar == 0 } {# puts "loopcounter: $loopCounter"
set a [expr int((100*$loopCounter)/$maxLoopCounter)]
showProgress $a
update
} elseif {$catchVar != 0 } {# puts "catchVar: $catchVar" # puts "Quit!"
destroyProgressBar
break
}
}#-----------------------------------------------------------------------------
# Progress Bar Procedures # Creates, updates and destroys a progress bar.
# Passed 'percent', the percentage completion. # eg progressBar 10 # shows the progress bar at 10%
# Reference: poor man's progressbar # https://wiki.tcl-lang.org/9621
#----------------------------------------------------------
proc createProgressBar { barColour } {
# Establish the screen location for the progress bar
set progressOrgX +900
set progressOrgY +200# If the .progressBar window has been created, destroy it and re-create it.
if {[winfo exists .progressBar]} {
destroy .progressBar
}# Create the toplevel
toplevel .progressBar
wm resizable .progressBar 0 0
wm title .progressBar "Progress"
wm geometry .progressBar $progressOrgX$progressOrgY
wm protocol .progressBar WM_DELETE_WINDOW {destroy .progressBar}
# Create the canvas that holds the progress bar
canvas .progressBar.c \
-width 200 \
-height 20 \
-bd 1 \
-relief sunken \
-highlightthickness 0# Create the progress bar itself
.progressBar.c create rectangle 0 0 0 20 \
-tags bar \
-fill $barColour # Display the assembled canvas and bar
pack .progressBar.c \
-padx 10 \
-pady 10
focus -force .progressBar.c
raise .progressBar
}#----------------------------------------------------------
proc destroyProgressBar { } {
destroy .progressBar
}#----------------------------------------------------------
proc showProgress {percent} {
# Set the length of the progress bar
# puts "percent: $percent"
.progressBar.c coords bar 0 0 [expr {int($percent * 2)}] 20
}