Tk中进度条(Progress Bar)的实现

# 2008/12/03 01:05 @ Sean Zhang

Tk 本身没有内置的进度条的。目前看到三种实现方案。

基于 scale 控件的

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

基于 canvas 控件的实现

• 参考 http://wiki.tcl.tk/9621

style="max-width:640px"/> style="max-width:640px"/>

• 进度条

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

• 圆形的

    # 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
  

基于 frame 控件的

• 参考 http://wiki.tcl.tk/15491

#---------------
 # progress.tcl
 #---------------
 # Created by William J Giddings, 2006
 #
 # Simple progress bar with minimal options
 #
 # Notes: Value sent to bar must be within range 0.0 - 1.0
 #
 #---------------
 # Credits: http://wiki.tcl.tk/1146
 #---------------

 #---------------
 # simple progress bar
 #---------------
 proc progress {w args} {
  eval frame $w $args ;# create the "base" thing
  frame $w.bar -background blue -relief raised -borderwidth 6
  place $w.bar -relwidth .3 -relheight 1.0

  rename $w _$w      ;# keep the original widget command
  # Here comes the overloaded widget proc:
  proc $w {args} {
    set self [lindex [info level 0] 0] ;# get name I was called with
    foreach {opt val} $args {
	switch -- $opt {
	  -val   {eval "place $self.bar -relwidth $val"}
	  default {uplevel 1 _$self $args}
	  }
	}
  }
  return $w ;# like the original "text" command
 }

 #---------------
 # Some demo stuff
 #---------------
 pack [frame .fr1 ] -fill x
 foreach {i j} {1 0.25 2 0.50 3 0.75 } {
  pack [button .fr1.b$i -text $j -command ".pg -val $j" -width 5] -side left
 }
 pack [progress .pg -height 16 -width 120 -borderwidth 2 -relief sunken]