📄 progressbar1.wgt
字号:
Class Progressbar1
Lib vtcl
CreateCmd ::progressbar::progressbar
Icon icon_progressbar.gif
Balloon 3d progressbar
DumpChildren no
MegaWidget yes
Resizable horizontal
TreeLabel @vTcl::widgets::vtcl::progressbar1::getWidgetTreeLabel
AliasPrefix Progressbar
InsertCmd vTcl::widgets::vtcl::progressbar1::insertCmd
ResizeCmd vTcl::widgets::vtcl::progressbar1::resizeCmd
# New options for this widget.
NewOption -color "color" type
NewOption -percent "percent" type
NewOption -shape "shape" choice "3d flat"
NewOption -textvalue "text value" type
NewOption -textcolor "text color" color {} Colors
namespace eval vTcl::widgets::vtcl::progressbar1 {
proc resizeCmd {widget w h} {
$widget configure -width [expr $w - 10]
}
proc insertCmd {target} {
set last [lindex [split $target .] end]
set last [vTcl:rename $last]
set name "[winfo toplevel $target]::$last"
$target configure -variable $name
}
proc getWidgetTreeLabel {target} {
set var [$target cget -variable]
if {$var != ""} {
return "3D Progress Bar VAR=$var"
} else {
return "3D Progress Bar"
}
}
}
# Routines that need to be exported to a saved project.
Export __progressbar_Setup
Export ::progressbar::progressbar
Export ::progressbar::Init
Export ::progressbar::Build
Export ::progressbar::WidgetProc
Export ::progressbar::HumanizeList
Export ::progressbar::Canonize
Export ::progressbar::RGBs
Export ::progressbar::Configure
Export ::progressbar::DestroyHandler
Export ::progressbar::Draw
proc __progressbar_Setup {} {
namespace eval ::progressbar {
# this is the public interface
namespace export progressbar
# these contain references to available options
variable widgetOptions
# these contain references to available commands
variable widgetCommands
# these contain references to available options for shape option
variable widgetShapes
# these contain references to global variables
variable widgetGlobals
set widgetGlobals(debug) 0
}
}
__progressbar_Setup
#
# Progressbar Widget written in pure tcl
#
# @(#)progressbar.tcl v1.3 00/04/28 (c) 2000 Alexander Schoepe
#
# Progressbar is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# Progressbar 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
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Progressbar; see the file COPYING. If not, write to
# the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
#
# Special thanks to Bryan Oakley his mclistbox was a very good example
# how to build a widget - GREAT SOURCE!
# Futhermore special thanks to Joerg Mehring who ask me just minutes
# before releasing "Is there a variable parameter?". So the release had
# to wait some more time and a variable parameter has been added.
#
# Always remember there is NO SUPPORT! eMail: tcl@sesam.com
#
# ############################### USAGE #################################
#
# NAME
# progressbar - Create and manipulate progressbar widgets
# SYNOPSIS
# progressbar pathName ?options?
# STANDARD OPTIONS
# -borderwidth or -bd, borderWidth, BorderWidth
# -relief, relief, Relief
# WIDGET-SPECIFIC OPTIONS
# -background, background, Background
# -width, width, Width
# -color, color, Color
# -percent, percent, Percent
# -shape, shape, Shape
# -variable, variable, Variable
# -width, width, Width
# WIDGET COMMAND
# pathName cget option
# pathName configure ?option? ?value option value ...?
#
# ############################## XSAMPLE ################################
#
# package require progressbar 1.3
#
# pack [set w [::progressbar::progressbar .pb]]
# for {set percent 0} {$percent <= 100} {incr percent} {
# $w configure -percent $percent
# update
# after 100
# }
# destroy $w
#
# set percent 0
# pack [::progressbar::progressbar .pb -variable percent]
# for {} {$percent <= 100} {incr percent} {
# update
# after 100
# }
# destroy $w
#
# ::progressbar::Init --
#
# Initialize the global (well, namespace) variables. This should
# only be called once, immediately prior to creating the first
# instance of the widget
#
# Results:
#
# All state variables are set to their default values; all of
# the option database entries will exist.
#
# Returns:
#
# empty string
proc ::progressbar::Init {} {
variable widgetOptions
variable widgetCommands
variable widgetGlobals
variable widgetShapes
if {$widgetGlobals(debug)} {
puts stderr "pb_Init"
}
# here we match up command line options with option database names
# and classes. As it turns out, this is a handy reference of all of the
# available options. Note that if an item has a value with only one
# item (like -bd, for example) it is a synonym and the value is the
# actual item.
array set widgetOptions {
-background {background Background }
-borderwidth {borderWidth BorderWidth }
-color {color Color }
-cursor {cursor Cursor }
-percent {percent Percent }
-relief {relief Relief }
-shape {shape Shape }
-variable {variable Variable }
-width {width Width }
-textvalue {textValue TextValue }
-textcolor {textColor TextColor }
-bg -background
-bd -borderwidth
-pc -percent
}
# this defines the valid widget commands. It's important to
# list them here; we use this list to validate commands and
# expand abbreviations.
set widgetCommands {
cget
configure
incr
step
}
# this defines the valid shape options. It's important to
# list them here; we use this list to validate options and
# expand abbreviations.
set widgetShapes {
3D
3d
flat
}
set widgetGlobals(toDraw) {
rect #bdbdbd es0 {[expr $mark +3] 2 [expr $width -2] 11} {-outline ""}
line #525252 es1 {[expr $mark +1] 2 [expr $mark +1] 11} {}
line #8c8c8c es2 {[expr $mark +2] 11 [expr $mark +2] 2 \
[expr $width -4] 2} {}
line #8c8c8c es3 {[expr $mark +3] 11 [expr $width -3] 11 \
[expr $width -3] 3} {}
line $rgb(0) pb0 {4 11 [expr $mark -1] 11 [expr $mark -1] 3} {}
line $rgb(1) pb1 {3 11 3 10 [expr $mark -2] 10 [expr $mark -2] 2 \
[expr $mark -1] 2 4 2} {}
line $rgb(2) pb2 {3 2 2 2 2 11 2 10 3 10 3 9 [expr $mark -3] 9 \
[expr $mark -3] 3 [expr $mark -2] 3 4 3} {}
line $rgb(3) pb3 {3 3 3 9 3 8 [expr $mark -3] 8 [expr $mark -3] 4 4 4} {}
line $rgb(4) pb4 {3 4 3 8 3 7 [expr $mark -3] 7 [expr $mark -3] 5 4 5} {}
line $rgb(5) pb5 {3 5 3 7 3 6 [expr $mark -3] 6} {}
line #000000 mrk {$mark 1 $mark 12} {}
line #adadad fr0 {0 12 0 0 [expr $width -1] 0} {}
line #ffffff fr1 {1 13 [expr $width -1] 13 [expr $width -1] 1} {}
line #000000 fr2 {1 1 [expr $width -2] 1 [expr $width -2] 12 1 12 1 1} {}
text #000000 txt {[expr $width / 2] 8} {-text $text}
}
set widgetGlobals(@blue0)\
{#000052 #0031ce #3163ff #639cff #9cceff #efefef}
set widgetGlobals(@blue1)\
{#000021 #00639c #009cce #00ceff #63ffff #ceffff}
set widgetGlobals(@blue2)\
{#000052 #31319c #6363ce #9c9cff #ceceff #efefef}
set widgetGlobals(@blue3) \
{#21214a #52527b #63639c #8484bd #b5b5ef #ceceff}
set widgetGlobals(@blue4)\
{#29396b #4a6b9c #6384b5 #739cd6 #94b5ef #adceff}
set widgetGlobals(@green0) \
{#003131 #08736b #318c94 #5abdad #63dece #ceffef}
set widgetGlobals(@green1)\
{#001000 #003100 #316331 #639c63 #9cce9c #ceffce}
set widgetGlobals(@green2)\
{#002100 #006331 #319c63 #31ce63 #63ff9c #ceffce}
set widgetGlobals(@green3)\
{#003131 #316363 #427b7b #639c9c #9ccece #bdefef}
set widgetGlobals(@yellow0)\
{#101010 #636300 #9c9c00 #cece00 #ffff00 #ffff9c}
set widgetGlobals(@yellow1)\
{#8c7321 #cead39 #e7c642 #f7de63 #f7de63 #ffffe7}
set widgetGlobals(@red0)\
{#420000 #9c0000 #ce3131 #ff6363 #ff9c9c #ffcece}
set widgetGlobals(@red1)\
{#210000 #9c3100 #ce6331 #ff9c63 #ffce9c #ffffce}
set widgetGlobals(@magenta0)\
{#210000 #630063 #9c319c #ce63ce #ff9cff #ffceff}
set widgetGlobals(@brown0)\
{#210000 #633100 #9c6331 #ce9c63 #efb573 #ffdeb5}
set widgetGlobals(@brown1)\
{#310000 #7b4242 #9c6363 #ce9c9c #efcece #ffdede}
set widgetGlobals(@gray0)\
{#212121 #525252 #737373 #adadad #cecece #efefef}
# this initializes the option database. Kinda gross, but it works
# (I think).
set tmpWidget ".__tmp__"
# steal some options from frame widgets; we only want a subset
# so we'll use a slightly different method. No harm in *not*
# adding in the one or two that we don't use... :-)
label $tmpWidget
foreach option [list Background Relief] {
set values [$tmpWidget configure -[string tolower $option]]
option add *Progressbar1.$option [lindex $values 3]
}
destroy $tmpWidget
# these are unique to us...
option add *Progressbar1.borderWidth 5 widgetDefault
option add *Progressbar1.color @blue0 widgetDefault
option add *Progressbar1.percent 0 widgetDefault
option add *Progressbar1.shape 3D widgetDefault
option add *Progressbar1.variable {} widgetDefault
option add *Progressbar1.width 180 widgetDefault
option add *Progressbar1.textColor black widgetDefault
# define the class bindings
# this allows us to clean up some things when we go away
bind Progressbar1 <Destroy> [list ::progressbar::DestroyHandler %W]
}
# ::progressbar::progressbar --
#
# This is the command that gets exported. It creates a new
# progressbar widget.
#
# Arguments:
#
# w path of new widget to create
# args additional option/value pairs (eg: -background white, etc.)
#
# Results:
#
# It creates the widget and sets up all of the default bindings
#
# Returns:
#
# The name of the newly create widget
proc ::progressbar::progressbar {args} {
variable widgetOptions
variable widgetGlobals
# perform a one time initialization
if {![info exists widgetOptions]} {
__progressbar_Setup
Init
}
if {$widgetGlobals(debug)} {
puts stderr "pb_progressbar '$args'"
}
# make sure we at least have a widget name
if {[llength $args] == 0} {
return -code error \
"wrong # args: should be \"progressbar pathName ?options?\""
}
# ... and make sure a widget doesn't already exist by that name
if {[winfo exists [lindex $args 0]]} {
return -code error "window name \"[lindex $args 0]\" already exists"
}
# and check that all of the args are valid
foreach {name value} [lrange $args 1 end] {
Canonize [lindex $args 0] option $name
}
# build it...
set w [eval Build $args]
# and we are done!
return $w
}
# ::progressbar::Build --
#
# This does all of the work necessary to create the basic
# progressbar.
#
# Arguments:
#
# w widget name
# args additional option/value pairs
#
# Results:
#
# Creates a new widget with the given name. Also creates a new
# namespace patterened after the widget name, as a child namespace
# to ::progressbar
#
# Returns:
#
# the name of the widget
proc ::progressbar::Build {w args} {
variable widgetOptions
variable widgetGlobals
if {$widgetGlobals(debug)} {
puts stderr "pb_Build '$w' '$args'"
}
# create the namespace for this instance, and define a few
# variables
namespace eval ::progressbar::$w {
variable options
variable widgets
variable info
}
# this gives us access to the namespace variables within
# this proc
upvar ::progressbar::${w}::widgets widgets
upvar ::progressbar::${w}::options options
upvar ::progressbar::${w}::info info
set info(rgb) ""
set info(rgbHasChanged) 0
# this is our widget -- a frame of class Progressbar. Naturally,
# it will contain other widgets. We create it here because
# we need it to be able to set our default options.
set widgets(this) [frame $w -class Progressbar1]
# this defines all of the default options. We get the
# values from the option database. Note that if an array
# value is a list of length one it is an alias to another
# option, so we just ignore it
foreach name [array names widgetOptions] {
if {[llength $widgetOptions($name)] == 1} continue
set optName [lindex $widgetOptions($name) 0]
set optClass [lindex $widgetOptions($name) 1]
set options($name) [option get $w $optName $optClass]
if {$widgetGlobals(debug) > 1} {
puts stderr "pb_Build:Opt '$w' '$optName' '$optClass' '$options($name)'"
}
}
# now apply any of the options supplied on the command
# line. This may overwrite our defaults, which is OK
if {[llength $args] > 0} {
array set options $args
}
# this will only set the name of canvas's widget, we will
# later create the canvas in our drawing procedure.
set widgets(canvas) $w.pb
# we will later rename the frame's widget proc to be our
# own custom widget proc. We need to keep track of this
# new name, so we'll define and store it here...
set widgets(frame) ::progressbar::${w}::$w
# this moves the original frame widget proc into our
# namespace and gives it a handy name
rename ::$w $widgets(frame)
# Alias the window to our WidgetProc and pass the window name.
interp alias {} ::$w {} ::progressbar::WidgetProc $w
# ok, the thing exists... let's do a bit more configuration.
if {[catch "Configure $widgets(this) [array get options]" error]} {
return -code error $error
catch {destroy $w}
}
return $w
}
# ::progressbar::WidgetProc --
#
# This gets uses as the widgetproc for an progressbar widget.
# Notice where the widget is created and you'll see that the
# actual widget proc merely evals this proc with all of the
# arguments intact.
#
# Note that some widget commands are defined "inline" (ie:
# within this proc), and some do most of their work in
# separate procs. This is merely because sometimes it was
# easier to do it one way or the other.
#
# w widget pathname
# command widget subcommand
# args additional arguments; varies with the subcommand
#
# Results:
#
# Performs the requested widget command
proc ::progressbar::WidgetProc {w args} {
variable widgetOptions
variable widgetGlobals
if {[llength $args] == 0} {
return -code error [vTcl:WrongNumArgs "$w option ?arg arg ...?"]
}
set command [lindex $args 0]
set args [lrange $args 1 end]
if {$widgetGlobals(debug)} {
puts stderr "pb_WidgetProc '$w' '$command' '$args'"
}
upvar ::progressbar::${w}::widgets widgets
upvar ::progressbar::${w}::options options
upvar ::progressbar::${w}::info info
set command [Canonize $w command $command]
set result ""
switch $command {
cget {
if {[llength $args] != 1} {
return -code error "wrong # args: should be $w cget option"
}
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -