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 0

Notice 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 go

You 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 .go

There 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

WikiDbImage PoorManProgress.png

  # 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.

WikiDbImage PoorManProgress2.png

  # 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 green

Process 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
        }