Windows Application Framework
EKB 2005-07-08:
I have now Snitified this package. The code samples have been replaced with the new Snit versions.''
I've been working towards making a package that will automatically take care of some tricks for using Tk under Windows that I learned once and don't want to have to learn again. For example:
- Binding the "x" button to the exit procedure
- Linking to an .ico file
- Creating a resizer/gripper in the bottom-right corner (using code from the sizer control page on this Wiki)
- Creating tooltips (also known as balloon help) using the code from the Snit Tooltips page
- Creating a toolbar and finding button images for it (I embedded some inline images, but you might want to use ICONS instead!)
- Adding a status bar, and connecting it to the toolbar buttons
- Saving preferences in the user's directory
- ... and so on ...
I've put some of these things together into a simple application framework. It uses some of my own code, as well as code from other pages on the Tcler's Wiki and the web. (These are documented in the code.)
Here's an example of an application created using the Application Framework code (This is actually the program I used to create the base64-encoded button strings that appear in the Framework, so it is hopefully useful by itself.)
To use the "Transparent Color" feature in the program, first fill any areas in the image that you want to make transparent with some color, for example, pure green (R = 0, G = 255, B = 0). Then type those numbers into the R, G, B entry widgets. When the image is loaded, any pixels that are set to (0,255,0) will be made transparent. The screenshot above shows this image loaded in the program: 
.
And here's the code to make the example, using the Application Framework (which is farther down on the page) A couple of things to notice in the code:
- Any values assigned to the "globalPrefs" array or set using the "myapp setpref" method are automatically saved on exit and retrieved when the program is restarted
- Balloon help is available for all widgets, including toolbar buttons
Example
package require base64
## -- Do this before making the GUI
source "AppFrame.tcl"
WinApp::appframe myapp -title "Translate Gif" -statusrelief groove
## -- Set any preferences
myapp setpref folder $WinApp::appdir
## -- Init will load preferences and set the focus
myapp init
## -- Create the GUI
[myapp menu] add cascade -label "File" -menu [myapp menu].file
menu [myapp menu].file -tearoff false
[myapp menu].file add command -label "Open" -command FindFile
[myapp menu].file add command -label "Exit" -command {myapp exitproc} \
-underline 1 -accelerator "Ctrl+Q"
set openBtn [myapp addButton -imagedata open -descr "Browse for a GIF file" \
-shortdescr "Find file" -command FindFile]
set copyBtn [myapp addButton -imagedata copy -descr "Copy base64-encoded string" \
-shortdescr "Copy encoded image" -command CopyAll]
# Interface
text [myapp main].t -height 1
pack [myapp main].t -side top -expand yes -fill both
frame [myapp main].f
pack [myapp main].f -fill x -side top
label [myapp main].f.l -text "File: "
pack [myapp main].f.l -side left
entry [myapp main].f.e -textvariable filename
pack [myapp main].f.e -side left -expand yes -fill x
button [myapp main].f.b -text "Browse..." -command FindFile
pack [myapp main].f.b
# A button to put the image preview in
image create photo sampleImg
frame [myapp main].fi
pack [myapp main].fi -fill x -padx 2 -pady 4
label [myapp main].fi.trans -text "Transparent color: "
pack [myapp main].fi.trans -side left
label [myapp main].fi.rl -text " R"
pack [myapp main].fi.rl -side left
entry [myapp main].fi.r -width 4 -textvariable WinApp::globalPrefs(red)
pack [myapp main].fi.r -side left
label [myapp main].fi.gl -text " G"
pack [myapp main].fi.gl -side left
entry [myapp main].fi.g -width 4 -textvariable WinApp::globalPrefs(green)
pack [myapp main].fi.g -side left
label [myapp main].fi.bl -text " B"
pack [myapp main].fi.bl -side left
entry [myapp main].fi.b -width 4 -textvariable WinApp::globalPrefs(blue)
pack [myapp main].fi.b -side left
button [myapp main].fi.i -image sampleImg -activebackground red -width 22 -height 22
pack [myapp main].fi.i -side right -anchor e
WinApp::tooltip register [myapp main].fi.i "Press to check transparency"
label [myapp main].fi.preview -text "Preview: "
pack [myapp main].fi.preview -side right -anchor e
## -- Commands
proc CopyAll {} {
[myapp main].t tag remove sel 1.0 end
[myapp main].t tag add sel 1.0 end
tk_textCopy [myapp main].t
}
proc FindFile {} {
global filename
set filename [tk_getOpenFile -initialdir [myapp getpref folder] \
-filetypes {{{GIF files} {.gif} } {{All files} * }}]
if {$filename == ""} {return}
myapp setpref folder [file dirname $filename]
# Open the file
sampleImg config -file $filename
# Add transparency, if need be
set maxX [image width sampleImg]
set maxY [image height sampleImg]
for {set x 0} {$x < $maxX} {incr x} {
for {set y 0} {$y < $maxY} {incr y} {
set curcolor [sampleImg get $x $y]
set istcolor true
if {[lindex $curcolor 0] != [[myapp main].fi.r get]} {
set istcolor false
} elseif {[lindex $curcolor 1] != [[myapp main].fi.g get]} {
set istcolor false
} elseif {[lindex $curcolor 2] != [[myapp main].fi.b get]} {
set istcolor false
}
if $istcolor {sampleImg transparency set $x $y true}
}
}
sampleImg write "_temp.gif" -format GIF
set fileID [open "_temp.gif" RDONLY]
fconfigure $fileID -translation binary
set rawData [read $fileID]
close $fileID
set encodedData [base64::encode $rawData]
sampleImg config -data $encodedData
[myapp main].t delete 1.0 end
[myapp main].t insert end $encodedData
}If this application and/or the framework seem useful, please add to them, modify them and improve them!
Framework
Here's the framework as it currently stands (last modified 8 July 2005). It includes a lot of embedded image data with standard button images (open, save, etc.) -- use [WinApp::buttonlist] to see the pre-defined images.
package require snit
namespace eval WinApp {
## -- Utility proc to easily insert a stub
proc stub {msg} {
tk_messageBox -message $msg -title "STUB"
}
# An array of buttons, defined for convenience (see below)
variable btn
# An array of prefs that apply to all appframes
variable globalPrefs
# Save the directory from which the program is called & info about user dirs
variable appdir [file dirname $argv0]
snit::type appframe {
##
## Options
##
option -title "AppFrame Application"
option -exitproc ""
option -statusrelief flat
option -icon ""
option -toplevel "."
##
## Variables
##
typevariable USERDIR
typevariable USERPREFS
# Array with various window components -- main, menu, statusbar, toolbar
variable component
# Array with prefs to save and restore
variable prefs
## Keep track of numbers of separators and buttons on the toolbar
variable tbSepNum 0
variable tbBtnNum 0
# This is accessed via the selfns
variable status
constructor {args} {
$self configurelist $args
# Generic prefs
set prefs(geometry) 300x200
set prefs(isMaximized) false
##
## Create the menu
##
# Take care of case where toplevel is just "." -- don't have multiple "."'s
if {$options(-toplevel) == "."} {
set tlvl ""
} else {
set tlvl "$options(-toplevel)"
}
$options(-toplevel) configure -menu $tlvl.appframeMenu
set component(menu) [menu $tlvl.appframeMenu]
if {$options(-icon) != ""} {
wm iconbitmap $options(-toplevel) -default $options(-icon)
}
wm title $options(-toplevel) $options(-title)
# Put the exit procedure action in 2 places -- "x" button and keyboard shortcut
wm protocol . WM_DELETE_WINDOW [mymethod exitproc]
bind . <Control-q> [mymethod exitproc]
## Toolbar
set component(toolbar) [frame $tlvl.appFrameToolbar]
grid $tlvl.appFrameToolbar -row 0 -sticky ew -columnspan 2
## Status bar & resizer
set component(statusbar) [frame $tlvl.appFrameStatus -height 10]
grid $tlvl.appFrameStatus -row 2 -sticky ew
label $tlvl.appFrameStatus.announce -textvariable [myvar status] -anchor w \
-relief $options(-statusrelief)
pack $tlvl.appFrameStatus.announce -side left -fill x -expand yes
# Make this the same size as the resizer to give it room
frame $tlvl.appFrameStatus.resizer -width 16 -height 16
pack $tlvl.appFrameStatus.resizer -side right
WinApp::sizer::sizer $options(-toplevel)
## Main app space
set component(main) [frame $tlvl.appFrameMain]
grid $tlvl.appFrameMain -row 1 -sticky nsew
## Application grid
grid rowconfig $options(-toplevel) 1 -weight 1
grid columnconfig $options(-toplevel) 0 -weight 1
}
##
## Methods
##
method init {} {
$self LoadPrefs $options(-title) "prefs.tcl"
# Have to do this, at least in Windows, to ensure app has focus when started
focus -force .
}
method getpref {id} {
return $prefs($id)
}
method getprefids {} {
return [array names prefs]
}
method setpref {id val} {
set prefs($id) $val
}
method component {item} {
if {![info exists component($item)]} {
error "\"$item\" is not a recognized AppFrame component"
}
return $component($item)
}
# Shortcut for "$self component main"
method main {} {
return $component(main)
}
# Shortcut for "$self component menu"
method menu {} {
return $component(menu)
}
## -- An exit procedure that saves preferences and exits
method exitproc {} {
# handler is the user's exit handler
if {$options(-exitproc) != ""} {
eval $options(-exitproc)
}
$self SavePrefs
exit
}
method setStatus {msg} {
set status $msg
}
method clearStatus {} {
set status ""
}
## -- Proc to add variables to the toolbar
#
# Switches:
# -image User-defined image
# -imagedata ID for a pre-defined inline button image
# -descr Text that appears in the status bar when over button
# -shortdescr Text that appears in balloon help when over button
# -command The command for the button
#
# NOTE: An image is required for toolbar buttons
#
method addButton {args} {
set button afBtn$tbBtnNum
incr tbBtnNum
set retval [button $component(toolbar).$button -relief flat -borderwidth 1]
pack $component(toolbar).$button -side left
set descr ""
set shortdescr ""
set command "WinApp::stub $button"
set image ""
foreach {opt val} $args {
switch -exact -- $opt {
-imagedata {set image [image create photo -data $WinApp::btn($val)]}
-image {set image $val}
-descr {set descr $val}
-shortdescr {set shortdescr $val}
-command {set command $val}
}
}
if {$image == ""} {
error "No image for button \"$button\""
return
}
$component(toolbar).$button config -image $image
$component(toolbar).$button config -command $command
bind $component(toolbar).$button <Enter> "set [myvar status] \"$descr\"; if {\[%W cget -state\] == \"normal\"} {%W configure -relief raised}"
bind $component(toolbar).$button <Leave> "set [myvar status] \"\"; %W configure -relief flat"
if {$shortdescr != ""} {
WinApp::tooltip register $component(toolbar).$button "$shortdescr"
}
return $retval
}
## -- Proc to add a separator to the toolbar
method addSep {} {
frame $component(toolbar).sep$tbSepNum -width 5 -borderwidth 0
pack $component(toolbar).sep$tbSepNum -side left -fill y -padx 4
incr tbSepNum
}
##
## Manage Prefs
##
method LoadPrefs {progname prefsfile} {
# Get current user's home directory: If environment vars not available,
# default to subfolder of the installation folder
set USERDIR $WinApp::appdir
if {$::tcl_platform(os) == "Windows NT"} {
if {[info exists ::env(USERPROFILE)]} {
set USERDIR $::env(USERPROFILE)
}
}
if {$::tcl_platform(os) == "Windows 95"} {
if {[info exists ::env(windir)] && [info exists ::env(USERNAME)]} {
set USERDIR [file join $::env(windir) Profiles $::env(USERNAME)]
}
}
set USERDIR [file join $USERDIR "Application Data" $progname]
set USERPREFS [file join $USERDIR $prefsfile]
if {[file exists $USERPREFS]} {
source $USERPREFS
}
wm geometry . $prefs(geometry)
if {$prefs(isMaximized)} {
wm state . zoomed
}
}
method SavePrefs {} {
if {![file exists $USERDIR]} {
file mkdir $USERDIR
}
# Find out if the window is zoomed
if {[wm state .] == "zoomed"} {
set prefs(isMaximized) true
} else {
set prefs(isMaximized) false
# Store the current window geometry
set prefs(geometry) [wm geometry .]
}
# Don't bother about errors. If can't open, then can't save prefs. That's OK.
if {![catch {open $USERPREFS w} fileID]} {
foreach item [array names prefs] {
puts $fileID "set prefs($item) \"$prefs($item)\""
}
foreach item [array names WinApp::globalPrefs] {
puts $fileID "set WinApp::globalPrefs($item) \"$WinApp::globalPrefs($item)\""
}
close $fileID
}
}
}
namespace eval sizer {
######################################################################
#
# From [email protected] (Tcler's Wiki)
# Modified by EKB to give the glyph more "breathing room"
#
######################################################################
namespace export sizer
}
proc sizer::sizer {win} {
variable config
variable f
if {$win=="."} {
set config($win-widget) .sizer
} else {
set config($win-widget) $win.sizer
}
canvas $config($win-widget) -width 16 -height 16 -cursor "size_nw_se" -bg SystemButtonFace
foreach i {0 4 8} {
# -width 2 means 2point on win98 and 2pixel on w2k
$config($win-widget) create line [expr $i+3] 13 14 [expr $i+2] -width 1 -fill SystemButtonShadow
$config($win-widget) create line [expr $i+2] 13 14 [expr $i+1] -width 1 -fill SystemButtonShadow
$config($win-widget) create line [expr $i+1] 13 14 $i -width 1 -fill SystemButtonHighlight
}
set config($win-zoomed) 2 ;# not 0/1
bind $config($win-widget) <Button-1> [namespace code [list sizer_start $win %X %Y]]
bind $config($win-widget) <B1-Motion> [namespace code [list sizer_move $win %X %Y]]
bind $win <Configure> [namespace code [list sizer_update $win]]
}
proc sizer::sizer_update {win} {
variable config
set zoomed [string equal [wm state $win] "zoomed"]
if {$zoomed!=$config($win-zoomed)} {
set config($win-zoomed) $zoomed
if {$zoomed} {
place forget $config($win-widget)
} else {
set x [expr {-16+[$win cget -padx]}]
set y [expr {-16+[$win cget -pady]}]
place $config($win-widget) -relx 1.0 -rely 1.0 -x $x -y $y
}
}
}
proc sizer::sizer_start {win x y} {
variable config
set config($win-x) $x
set config($win-y) $y
scan [wm geometry $win] "%dx%d" config($win-width) config($win-height)
}
proc sizer::sizer_move {win x y} {
variable config
set width [expr $config($win-width) +$x-$config($win-x)]
set height [expr $config($win-height)+$y-$config($win-y)]
catch {wm geometry $win ${width}x${height} }
}
##
## Button images
##
proc buttonlist {} {
variable btn
return [lsort [array names btn]]
}
## -- File operations
set btn(save) {
R0lGODlhEwASAJEAANnZ2QAAAICAAMDAwCH5BAEAAAAALAAAAAATABIAAAJi
hI+py0jxEQl2SNB8iwmCHRI03yKCYIcEzbeQINghQfMtJAh2SNB8CwmCHRI0
30KCYIcIxTeRINhB8tGCYIcIxT8Jgh0iFH8mJAh2iFD8mZAg2CFC8WdCguBT
fDyCj6nLSQUAOw==
}
set btn(open) {
R0lGODlhEwASAKIAANnZ2QAAAP//AP///4CAAP///////////yH5BAEAAAAA
LAAAAAATABIAAANnCLrc/jAyFIqgyx0IGhAIutyKEQiqEYGgqxEYAACBMoKh
Gwi6GoMyMjIoEwi6GoIjIyM4Egi6GoMygqHLAQgQMoKBpLsBCAAxgoGku4Gg
GhJIuhsIuhFIuhsIuoChy4Ggy+0Po4QoAQA7
}
set btn(new) {
R0lGODlhFwAWAJEAANnZ2U1NTf///////yH5BAEAAAAALAAAAAAXABYAAAJa
hI+py+0PoyLxjeBjBsmPIPiIQfJDguDjBcmPiCD4aEHyLwg+WpD8C4KPFiT/
guCjBcm/IPhoQfIvCD5akPwLgo8WJP+C4KMFyb8g+GgUH4PgY+py+8MopyEF
ADs=
}
set btn(print) {
R0lGODlhFwAWAKIAANnZ2U1NTf///9PT06ampv//Tf///////yH5BAEAAAAA
LAAAAAAXABYAAAN5CLrc/jDKSWtEobsIuryBoquBoMsbKBiqEgi6vIGiq4Gg
yxsoGKqygaDLgaKrMRgTCLqKocsTOBEIuhA4uhyDMYGgCxi6vIMTCLoQOLpE
hDMxgaCrgaNbVTgTEQi6iqHLOxgIuhs4uhuDgaDLgKHLgaDL7Q+jnLRClAA7
}
set btn(printpreview) {
R0lGODlhFwAWAKIAANnZ2U1NTf///9PT06ampk3//////////yH5BAEAAAAA
LAAAAAAXABYAAAOMCLrc/jDK6VDoLoIuc6DoSgSCLm+g6EoMBoIua6DoSgRG
IOgyBIouB4IuQ6DoSgRGIOgyBIpu0OBQIOhyoKgGFdYQBYLuBopqTOEMTSDo
bqCoxgzO0ASC7gaKatDgFFEg6G6g6AYNDgUh6G6g6EoERlAEgq4Gii4HYCiC
LmDosgJCBIIutz+MctLaUAIAOw==
}
## -- Formatting
set btn(bold) {
R0lGODlhFwAWAJEAANnZ2U1NTf///////yH5BAEAAAAALAAAAAAXABYAAAJG
hI+py+0Po5yUkfhG8DEhIghIBMHHjAijmPAxI8IoJnxMih8EHxMigoBEEHzM
iDCKCR8zIoxiwkek+EbwMXW5/WGUk9ZKCgA7
}
set btn(italic) {
R0lGODlhFwAWAJEAANnZ2U1NTaampv///yH5BAEAAAAALAAAAAAXABYAAAI8
hI+py+0Po5wUktgEHxMjhOBjokQQfMyMEIKPiRJB8DEzQgg+JkoEwcfMCCH4
mEfxCT6mLrc/jHLSagEpADs=
}
set btn(underline) {
R0lGODlhFwAWAJEAANnZ2U1NTaampv///yH5BAEAAAAALAAAAAAXABYAAAJL
hI+py+0Po5yUkThwQfAxIy4ohI8JEUcJ4WNCxFFC+JgQcZQQPiZEHCWEjwkR
RwnhY0KEEJQg+JhGsQk+pi4fxT+Cj6nL7Q+jnIcUADs=
}
set btn(justcenter) {
R0lGODlhFwAWAJEAANnZ2U1NTf///////yH5BAEAAAAALAAAAAAXABYAAAI2
hI+py+0Po4wkPiLBx9RVio8EH1NXKT4iwcfUVYqPBB9TVyk+IsHH1FWKjwQf
U5fbH0Y5qSMFADs=
}
set btn(justright) {
R0lGODlhFwAWAJEAANnZ2U1NTf///////yH5BAEAAAAALAAAAAAXABYAAAI2
hI+py+0Po4wkPiLBx9Rlio8EH1MXKT4iwcfUZYqPBB9TFyk+IsHH1GWKjwQf
U5fbH0Y5KSMFADs=
}
set btn(justleft) {
R0lGODlhFwAWAJEAANnZ2U1NTf///////yH5BAEAAAAALAAAAAAXABYAAAI2
hI+py+0Po4wkPiLBx9RFio8EH1OXKT4iwcfURYqPBB9Tlyk+IsHH1EWKjwQf
U5fbH0Y5KSQFADs=
}
set btn(justfull) {
R0lGODlhFwAWAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAXABYAAAI3
hI+py+0Po5xUkfiIBB9TFyk+IsHH1EWKj0jwMXWR4iMSfExdpPiIBB9TFyk+
IsHH1OX2h1FOUgA7
}
set btn(bullets) {
R0lGODlhFwAWAJEAANnZ2QAAgAAAAP///yH5BAEAAAAALAAAAAAXABYAAAJD
hI+py+0Po5QkJnzMjAgCKP8I/kUEwcfU5fYnMeFjZkQQQPlH8C8iCD6mLrc/
iQkfMyOCAMo/gn8RQfAxdbn9YZSHFAA7
}
set btn(numbering) {
R0lGODlhFwAWAJEAANnZ2QAAgAAAAP///yH5BAEAAAAALAAAAAAXABYAAAJF
hI+py+0PoyIhfEyNOJJ/BB8DERGBxISPqctLCeFjqoWR/CP4GIiICCQmfExd
XooJH1PjSP4RfITIzKSE8DF1uf1hlIgUADs=
}
set btn(decindent) {
R0lGODlhFwAWAJEAANnZ2QAAAAAAgP///yH5BAEAAAAALAAAAAAXABYAAAJG
hI+py+0PoyLxEQk+pi5SfESCj6mLQjAo/hF8E0GKfwQfSDbBx0QRpPhH8E+Q
4h/Bx9RFio9I8DF1keIjEnxMXW5/GKUkBQA7
}
set btn(incindent) {
R0lGODlhFwAWAJEAANnZ2QAAAAAAgP///yH5BAEAAAAALAAAAAAXABYAAAJG
hI+py+0PoyLxEQk+pi5SfESCj6mLQjAo/hH8EzmKfwQfSDbBx0yRo/hH8E+Q
4h/Bx9RFio9I8DF1keIjEnxMXW5/GKUkBQA7
}
## -- Editing
set btn(copy) {
R0lGODlhFwAWAJEAANnZ2U1NTf///01NpiH5BAEAAAAALAAAAAAXABYAAAJp
hI+py+0PIyLxCT6mhQhJCYKPCSFCUiQIPmZIBCmcT/ARgmTPyQzBx5CIoEwi
MjIE/4Jkj0TI0DaCbyERQRnlyxB8C5I9QrFlCL5R/CH5MgQfcYRiyxB8xCH5
MgQfkeYfwcfU5faHUU5SADs=
}
set btn(cut) {
R0lGODlhFwAWAJEAANnZ2U1NTU1Npv///yH5BAEAAAAALAAAAAAXABYAAAJY
hI+py+0PYyMBIAg+5sUFwce8uCD4mBcBlBA+JgYEwcfMiCD4mBqqekQRwcdM
ASGJ8DFBRAgCCMFHFBMgAULwEcUESIAQfEQxMZIIHxNECD6mLrc/jBKQAgA7
}
set btn(delete) {
R0lGODlhGAAWANUAANnZ2dQNN9ZkgtsUPN8BKtVgfud9ldVTc9EoTtE2WuzH
1twONtdFZ9QPON4BKt2Zr9crT9hBY+rZ5tcHMNwBKuGtwNU1WdM8X9oDLdoC
LObH19EnTefQ39ROcNwCK9kDLeiOpevi7dAhSNQLNd8CK+iIn+fJ2dMMNtgF
LtMQOd6csdkELdUKM9MTPOmUqueAmNRffdEYQN8DLO3q9NJJa+IzVf//////
/////////////////////////////////yH5BAEAAAAALAAAAAAYABYAAAaE
QIBwSCwaj8ikcslsLgMCJ3JAKDiPBgLhYEQkmooFgUFsOB5OAIQQAUgmlIpz
aCFcMBmNs7ghZIAcIEA4JBaJHc+HADIaiyFRZhQCkUpG49B0QqVCQhCpZDQC
VCtWK0R0kV5GI6wRCxldspexOKPNjEIgVw0IEA6JReMRmVQumU3nsxgEADs=
}
set btn(paste) {
R0lGODlhFQAWAKIAANnZ2U1NTf//TaamTaamptPT001Npv///yH5BAEAAAAA
LAAAAAAVABYAAAOKCLrc/jDKSStAoYGgy4uhKrKKQFdjkCYkAiVoKBB0IQgp
sHSDBgNBF2KQMHSVCANBF4JwaGgIh4YmEHQhBmlo0HQtEHQhCIeGDE/VDEEX
YpCGxvBU7QxBN2iQhuwMzc7M0BBUYwiHxvB01RBUgwZpyA5N9wxBF0PV8HTV
EHQZ0HQZQZfbH0Y5KUQJADs=
}
set btn(undo) {
R0lGODlhFwAWAJEAANnZ2U1Npqampv///yH5BAEAAAAALAAAAAAXABYAAAI+
hI+py+0Po5y0WkDiCMFHi4sgGCF3Z5QgCD4E4gUlhG+BeEFJCD4E4lFsgh1y
d3dniEL4mLrc/jDKSau9gBQAOw==
}
set btn(redo) {
R0lGODlhFwAWAJEAANnZ2aampk1Npv///yH5BAEAAAAALAAAAAAXABYAAAI9
hI+py+0Po5y0ThJJhOBjWgiSBAAh+AiSJgSJ4CNInpBE+AiSJiSJ4COEJMkm
+GgSBB9Tl9sfRjlptZeRAgA7
}
## -- Tools
set btn(checkspelling) {
R0lGODlhFwAWAJEAANnZ2U1NTU1Npv///yH5BAEAAAAALAAAAAAXABYAAAJh
hI+py+0PoyIBIgAgKISPFhBAQSAIPmJEACWAAAAgEf4FBAQhCAAQgo8BAUEB
IEIIPqaKqh4R4WOqqB6JsOXu7kgGgBF8TBARgkTwMU9ESISPmSJC8DFVCD6m
Lrc/jBKQAgA7
}
set btn(find) {
R0lGODlhFwAWAKIAANnZ2QAAAOzp2Kyomf///wD//wAAgP///yH5BAEAAAAA
LAAAAAAXABYAAAOCCLrc/jDKKVFoIOhyK0aIiGAEgi5z4BCRCMoEgi5vIFGV
CIoEgi5roFCh6Eog6DIEChWKrgSCLkOg6HIg6DIEii4Hgi5roOgKBYIub+Cg
qNIEgi5zYIgIDZoi6HIHRoSJoRmCLjejiZkh6HIzmpgZgi43o4kZgi53oxmC
Lrc/jHJGlAA7
}
set btn(replace) {
R0lGODlhFwAWAKIAANnZ2YAAAAAAAKyomezp2P///wD//wAAgCH5BAEAAAAA
LAAAAAAXABYAAAN9CLrc/jDKSR0KBF1uBxSBoMvNGKoIutyKARCBoMu9GACB
oMsqKCIAgIGgyyw4RCMIuhq8SKaKCEcAADAAAkEXhLCMiARBIzQQdEGQVEsA
AUMVQVdlkLRGAAEiEHQZBIdq5BAUYncXEpW7Q9DldjxF0OV2vEPQ5faHUU5a
J0oAOw==
}
set btn(paint) {
R0lGODlhFwAWALMAANnZ2YCAgAAAAP///wCAgMDAwP8AAIAAAAD//wAAgICA
AAAA/4AAgP//AP///////yH5BAEAAAAALAAAAAAXABYAAAS3EMhJq704671D
gCIEAYGcVAYxgxBBCAikkFLKEIQMQ0BSBAAiCAjkBGEEAcwRBMEE1BACAjll
KEuYIwhKUJUgIJCTJrLYESSoBpWAQE4qE2FHENUUFBDISSUMctIgIJCTgjDG
GKWUAkMQEMhJZSgwyCkEBHLSGcYoJYQQoIBATjrDGKWEEAIUEMhJZxhjlBJC
gAICOekMY4xSQghQQCAnnWGMUUoIAQoI5KQUCjklBHLSai/Oeu8IADs=
}
set btn(help) {
R0lGODlhGAAWAPcAANnZ2djh9NHc8dDb79Hb79Hc79Db8dPc6+Pn7+Tr+NPc
8eTo9f38/f////37/ODm89Ld8c3S3Ovv+OLq99bf8Pv//8bz/6jd/pjP/JHJ
/6nU//j+/////NTf8bq/x+nt9tTe8c7p/3Gy/4ev7N/i7PTw6+Dk8Xmk9k6M
/sre/////dLd8L3Ax+3x+tfg8+/x9tvq/0qK/12H3v//7v38/qG55///+v75
8z1z4DZx5u7z/+Dn9JOZpdLW3WuY9Stn4m6LyOPq8FJ/1wExvX+c12aM2hVU
0Xea4v79/r/I26Gjqdfg8ebt+zNr2zRp0ylfyiJZyRpVyRFMwcbQ4kBx0CFb
zTlrzvv7/NPe72Vnatnh8srY8yNczTNnzzBlzCxhzCBWxKi1z3uc4BtUxyxh
zSpfxu3x9dXf8E5PUtjh89be8h9XxTNnzjJmzCJbzGqGwpGt6BBLxC5jzClg
yyxfw/Hy89bg8kpLTvv6+DNjxSddyjRoziRcy2qJyt/n9zls0CRbyjJmzRxU
w1F5x/38+MXP4UxNUNPc8Pn6+pCo2A5JvS9jzSphzTtsy2mO2CpfyipeyRFI
ub3J4Ojt9pCXpFxeYdrg6tfh8v//+Fl+xw1GuxRPxpWkwnCS2RBLwQxGuIGa
zlJUV5CSmOzw+cfP3+Lq9f//9IGazxZNtz1luZqv2SRZwCVXuZ+v1f//99ni
9GtweGxucs/T2+Hl7bW9ztjj9OLi5KKxz5ar1LvG3fDx7PLz9tbh8np/iK+y
uNjb46Glr8bP49fh89nj9Nrj9Nji87C6yVRWWmlqbqeqsOLm7t/j67W4v2Zn
a0tMT0hJTHV3e8THz+fq8///////////////////////////////////////
////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////
/////////////////////yH5BAEAAAAALAAAAAAYABYAAAj/AAEIHEiwoMGD
CBMqXMhQYAABAwgUMHAAQUMACRQsYNCgQQMHDyBEkLBwAoUGFSxcwJBBwwYO
HTx8UAiiQQgRI0iUMHECRQoVK1i0QOjiBYwYMmbQqGHjBo4cOnbw6IEQRAMf
P4AEETKESIMiRo4gSaIE4RImTZw8gRJFypQGVKpYuYIlC0ItW7h08fIFTJgG
YsaQKWPmDBqEadSsYdPGzZsGcOLImUOnjp07CF3gyaNnD58+fv4ACiRoEKFC
hhAeQpRI0SJGjRw9kgMpkqRJlCohtHQJUyZNmzg16OTpEyhMdkKJQjiKVClT
p1ClUrWKVStXr2DFkpVwFq1aeGzdOMKVS9cuXr2y+Pqg8BewYMKGESsmzNgx
ZMmUMVzGrJkzgM8EooEWTRpAAAIHEixo8CDChAoXMgwIADs=
}
set btn(zoomin) {
R0lGODlhGAAWAOYAANnZ2dvj9ay33Zqr2put3Z6u2q2439bd8c3W756t2rvO
6sXp+b7w/rjl+aPE65yt3MzV7pqr2d7q9v///8nr/7jo/6/i/77x/6za+pqq
2brE56fB5OX9/9ju/5HR9C10xcf5/8Dy/8b4/6C74q653qSz37nk9r7r/6nd
9L/u+s7//77n+Z2u3r/x/q7h/wFnzNr//9H9/qa14LLT8bns/5vN8p7Q8c3c
6uf//8To9J+v277J6Zqt3cbz/7bo/7fm8vj///7///3//6K32bjF5fDu8NnV
1pyq0pm15MDw/9H//9j//+D//+7//9Dd7KKx2/zEc/ipT5eUoKGv2Jqt2J+9
4L3d7b7b7aa226Sx3NHZ8PqlRcF1TKSAh9PZ78DM66Wz3Z2v3qe24KR+hbu4
1uDb1fCiSNTX3oBxaKB7gby20ubp8dPV4f//////////////////////////
/////////////////////////////////////////////////yH5BAEAAAAA
LAAAAAAYABYAAAfQgACCg4SFhoeIiYqLjIUBAgMEBQYHjYMICQoLDA0ODxCN
AAEREhMUFRYXGBkBjRobHB0eHyAhIiMkjSUmJx4eHygpKisDjSwtLi8fHx8f
MDEEjTIzNDU2Hzc3ODk6jTs8PT4/H0BBQkNEjEVGR0hJSktMTU5PAYtFUFFS
U1RVVoBXWFlagACCg4QARVBbXF1eX2BhYl8BhYUARVBbXGNkhYWFgkVQW1xj
ZIWFhYNlZlxjZIWFhYRnaGlqhYWFhQBrbIAAgoOEhYaHiImKi4yLgQA7
}
set btn(zoomout) {
R0lGODlhGAAWAOYAANnZ2dvj9b3I6KOy3Zut3Zqr2pqp1dHZ8Ke13qCv17LT
68Hy/rjg9p64456u28zV7qi237/M5f///+D3/7fn/7Pl/77x/6jU9Zyr2sDM
66e64e/9//b8/8Tm/7zu/7Di/7Hk/8b2/5265Km02qe34LLO7Mr1/7Hd+c3+
/7zn+Z2v3rLY8rTn/4Gz5gFnzN3//838/qe24LDO7rvu/8LR4+j//8nw+aCz
38Xx/7Tm/8///9////L///3///r//7bR6qGv2qPG8Mf1/8n7/9r//+b///H/
/+7y+p+v29Xb8PXauvG2ZKSntZup1Jmz37vi+dD7/rjT68LK5v+3UuOKP6Bz
asjN37nF5p6t27C64axyZaSSsN/i86SRrejg2/+4U9TX3qCAYK1yY8PFy7m2
w///////////////////////////////////////////////////////////
/////////////////////////////////////////////////yH5BAEAAAAA
LAAAAAAYABYAAAfZgACCg4SFhoeIiYqLjIUBAgMEBQYBjYMHCAkKCwwNDg+N
AAEQERITFBUWFxgBjRkaGxwdHh8gISIjjSQlJieAKIKCKQWAAIKDhIMqKywt
Li4uLi8wBIWFgzEyM4A0goI1NgWAAIKDhIMZNzg5Ojs8PT4/I4WFgwFAQUJD
REVGR0hJhYWCSktMTU5PUDZRSFKFhYJKU1RVVldYBAVZAYWFgkpTVFpbXIWF
hYJKU1RaXVyFhYWCXl9UWl1chYWFg2BhYl1chYWFhWNkXIAAgoOEhYaHiImK
i4yKgQA7
}
## -- Objects
set btn(clipart) {
R0lGODlhFwAWALMAANnZ2QAAAICAgP///4AAAIAAgMDAwP//AICAAP//////
/////////////////////yH5BAEAAAAALAAAAAAXABYAAATMEMhJq704622D
gEEEEUQQQQQRIJBTCjjkpFNAIKcMY4whCCEEijFGgEBOKcYYAxI5xxgCAjll
GGOMIkohkIgxAgRySjHGGMGEQyARYwgI5JRhjIHKKUNAIsYIEMgpxRhilDCO
gKKMISCQU4YxRghFjADLGCNAIKcUY4yBwjABDjkEBHLKMMYYYhwU4JAjQCCn
FGOMIQoSAg45BARyyjCGECOEUmAIYwQI5JRiiDJGKafAIsQQEMgpgwgiiCCC
gEEEESCQk1Z7cdabdwsjADs=
}
set btn(table) {
R0lGODlhFwAWAKIAANnZ2QAAAAAAgICAgP///////////////yH5BAEAAAAA
LAAAAAAXABYAAAN8CLrc/jDKSStDocsdCLoQKLrMgaALgaLLHAi6EDi6zIGg
C0FIQ0SDpKMUCLoQhDRENEg6SoGgC4GjyxwIuhCENEQ0SDpKgaALQUhDRIOk
oxQIuhA4usyBoAtBSENEg6SjFAi6EIQ0RDRIOkqBoAsYutyBoMvtD6OctFqL
EgA7
}
set btn(picture) {
R0lGODlhFwAWAKIAANnZ2QAAAP//AP///4CAgMDAwP///////yH5BAEAAAAA
LAAAAAAXABYAAAOACLrc/jDKSau9KHRZEXQZAmVkZFBGJhB0GQJHRkaQgiQQ
dBkCZWRkMComEHQZAkdGRpCCJBB0GQJlZGRQRiYQdBkCRyZGcGQkEHQZAmWC
YjBCJhB0GQIniCiwKiQQdBkCgyiIMKoiEHQZAkkpNLAqEHQZMHRZEXS5/WGU
k1Z7AUoAOw==
}
## -- VCR controls
set btn(vcrback) {
R0lGODlhFQAVAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAVABUAAAI6
hI+py+0Po3wkhI+JEapKYsLHtIigED4mUGyCjwkUm+BjWkRQCB/zIoLgY2KE
qhoSwsfU5faHUc5JCgA7
}
set btn(vcrgoend) {
R0lGODlhFgAWAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAWABYAAAJY
hI+py+0Po5wUkAAAAQCEhOBjxEUQnDAzM4oBFgBG8DEiAigOGMFHio9G8JHi
oxF8jIgAigNG8DEiLCgBRBB8jLgIghNmZkYBAAIACAnBx9Tl9odRTgpIAQA7
}
set btn(vcrff) {
R0lGODlhFgAWAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAWABYAAAJK
hI+py+0Po5zUkAAAQfAxIeIoIXzMiDCKCR8xIoKQRBB8PIqPBB+N4iPBR4uI
ICQRBB8vIoxiwkeMuKAQPmZgEHxMXW5/GOWkihQAOw==
}
set btn(vcrforward) {
R0lGODlhFQAVAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAVABUAAAI7
hI+py+0Po5yThPAxM0JVAYkJH/MigkL4mEaxCT4mUGyCjwkRQSF8TIsIgo95
EaoKSAgfU5fbH0b5SAEAOw==
}
set btn(vcrpause) {
R0lGODlhEgASAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAASABIAAAJB
hI+py+0PSQIwgo8WYUEhfLQICwrho0VYUAgfLcKCQvhoERYUwkeLsKAQPlqE
BYXw0SIsKISPFmFBIXxMXW5/SAoAOw==
}
set btn(vcrrewind) {
R0lGODlhFgAWAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAWABYAAAJK
hI+py+0Po5xUkQAAQfAxIy4ohI8YEUYx4eNFRBCSCIKPRvGR4KNRfCT4eBER
hCSC4CNGhFFM+JgRFxTCx4TAIPiYutz+MMpJDSkAOw==
}
set btn(vcrgostart) {
R0lGODlhFgAWAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAWABYAAAJa
hI+py+0Po5wUkAQAEAAEhOBjxEUQnDAzM0oAFgAWBB8jIIISREQQfKT4aAQf
KT4awccIiKAEEREEHyMsggJEBMHHiIsgOGFmZpQAAAKAgBB8TF1ufxjlpIAU
ADs=
}
set btn(vcrstopcircle) {
R0lGODlhEgASAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAASABIAAAI0
hI+py+0PAYlN8NEofhB8pPhH8I/iH8E/in8E/yj+Efyj+EfwkeIHwUej2AQf
U5fbH8ZECgA7
}
set btn(vcrstopsquare) {
R0lGODlhFQAVAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAVABUAAAI7
hI+py+0Po5yQxD+Cj0bxj+CjUfwj+GgU/wg+GsU/go9G8Y/go1H8I/hoFP8I
PhrFP4KPqcvtD6OckBQAOw==
}
## -- Directions
set btn(down) {
R0lGODlhFAASAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAUABIAAAI/
hI+py+1M4uMRfKP4GAT/KD4GwUeKfwQfgeIfwUej+EHwESk2wcek2AQfEyKC
4GNaRBB8zAtVBRLCx9Tl9kekADs=
}
set btn(downleft) {
R0lGODlhFQATAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAVABMAAAJD
hI+py+1vSAgfMyNUFZCY8DEvIiiEj2kUm+BjAsUn+JgUPwg+IsU3go9H8Y/g
o1F8JPgIFB+D4CPFRyP4mLrc/tCRAgA7
}
set btn(downright) {
R0lGODlhFQATAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAVABMAAAJB
hI+py+0PSQgfEyNUlcSEj2kRQSF8TKDYBB+T4hN8RIofBB+P4hvBR6P4R/AR
KD4SfKT4GAT/KD4awcfU5faHjxQAOw==
}
set btn(left) {
R0lGODlhEgAUAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAASABQAAAI/
hI+py+1vSAgfMyIyj8Qm+GgUn+AjxTeCbxQfCT7FRyP4RvGR4CPFN4KPRvEJ
Ph7FJviYEZGZhoTwMXW5/RspADs=
}
set btn(right) {
R0lGODlhEgAUAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAASABQAAAJA
hI+py+1GQviYFhEEH5NiE3w8ik/w0Si+EXyk+EjwjeKjEXyKjwTfKL4RfKT4
BB+NYhN8vIjITBLCx9Tl9oeMFAA7
}
set btn(up) {
R0lGODlhFAASAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAUABIAAAI+
hI+py+1/SAgfE0NVKSZ8TIsIgo8JFJvgY1Jsgo9I8YPgo1H8I/gIFP8IPlJ8
DIJ/FB+D4BvFxyP4mLrc3qQAOw==
}
set btn(upleft) {
R0lGODlhFQATAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAVABMAAAJC
hI+py+0PH4mPRvCP4mMQfKT4SPARKP4RfDSKbwQfj+IHwUek+AQfk2ITfEyI
CArhY1pEEHzMi1BVQEL4mLrc/pAUADs=
}
set btn(upright) {
R0lGODlhFQATAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAVABMAAAJD
hI+py+0PHYmPRvCR4mMQfASKjwQfjeIfwcej+EbwESl+EHxMik/wMYFiE3xM
iwgK4WNeRBB8TIxQVUNC+Ji63P6GFAA7
}
#-----------------------------------------------------------------------
# Tooltip type
#
# The tooltip command is an instance of TooltipType, so that we can
# have options.
#
# Code posted by William Duquette to the Tcler's Wiki on page
# "Snit Tooltips"
snit::type TooltipType {
#-------------------------------------------------------------------
# Options
option -font {Helvetica 8}
option -background "#FFFFC0"
option -topbackground black
option -foreground black
option -delay 600
#-------------------------------------------------------------------
# Variables
# Tool tip text. An array, indexed by window name
variable tiptext
# Tool tip timeout, or {}
variable timeout {}
# Tool tip window, or {}
variable tipwin {}
#-------------------------------------------------------------------
# Constructor
# Implicit
#-------------------------------------------------------------------
# Public methods
method register {window text} {
set tiptext($window) $text
# Add "+" so other actions bound to these events will fire
bind $window <Enter> "+[mymethod Enter $window]"
bind $window <Leave> "+[mymethod Leave $window]"
}
method unregister {window} {
unset tiptext($window)
}
#-------------------------------------------------------------------
# Private Methods
# When the mouse pointer enters the window, set the timer.
method Enter {window} {
set timeout [after $options(-delay) [mymethod Popup $window]]
}
# Pop up the tooltip.
method Popup {window} {
# FIRST, the timeout has fired, so we can forget it.
set timeout {}
# NEXT, the tooltip will be a child of the window's toplevel.
set top [winfo toplevel $window]
# NEXT, the tooltip's name depends on which toplevel it is.
set tipwin ".gui_tooltip_window"
if {$top ne "."} {
set tipwin "$top$tipwin"
}
# NEXT, create the tooltip window.
frame $tipwin \
-background $options(-topbackground)
label $tipwin.label \
-text $tiptext($window) \
-foreground $options(-foreground) \
-background $options(-background) \
-font $options(-font)
# Pack the label with a 1 pixel gap, so that there's a box
# around it.
pack $tipwin.label -padx 1 -pady 1
# NEXT, the tipwin will be placed in the toplevel relative to
# the position of the registered window. We'll figure this out
# by getting the position of both relative to the root window.
set tx [winfo rootx $top]
set ty [winfo rooty $top]
set wx [winfo rootx $window]
set wy [winfo rooty $window]
# We want to the tip to appear below and to the right of the
# registered window.
set offset [expr {[winfo width $window]/2}]
# Compute the final position.
set x [expr {($wx - $tx) + $offset}]
set y [expr {($wy - $ty) + [winfo height $window] + 2}]
# Finally, place the tipwin in its position.
place $tipwin -anchor nw -x $x -y $y
# However, if window is to the right of its toplevel, the
# tipwin might be too wide. Slide it to the left, as needed.
# TBD: I don't know of any way to determine the width of the
# tipwin without letting it pop up, which causes an ugly
# jump.
update idletasks
set rightEdge [expr {$x + [winfo width $tipwin]}]
set topWid [winfo width $top]
if {$rightEdge >= $topWid} {
set x [expr {$x - ($rightEdge - $topWid + 2)}]
place $tipwin -anchor nw -x $x -y $y
}
}
# When the mouse pointer leaves the window, cancel the timer or
# popdown the window, as needed.
method Leave {window} {
if {$timeout ne ""} {
after cancel $timeout
set timeout ""
return
}
if {$tipwin ne ""} {
destroy $tipwin
set tipwin ""
}
}
}
#-----------------------------------------------------------------------
# The tooltip command
TooltipType tooltip
}