Version 12 of Windows Application Framework
Updated 2005-04-18 13:24:27 by escargoEKB 17 April 2005
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 a toolbar and finding button images for it
- Adding balloon help and a status bar 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.)
If this seems useful, please add to this, modify it and improve it!
Here's the framework as it currently stands (last modified 17 April 2005). It includes a lot of embedded image data with standard button images (open, save, etc.) -- use [appframe::buttonlist] to see the pre-defined images.
namespace eval appframe {
namespace export stub make clearStatus addButton addSep init buttonlist
##
## Variables
##
## -- Public variables
# Save the directory from which the program is called
variable appdir [file dirname $argv0]
variable toolbar
variable main
variable title "AppFrame Application"
variable statusbar
variable exitproc appframe::exitwrapper
variable status
variable prefs
variable USERDIR
variable USERPREFS
variable btn
## -- Initialize standard prefs
set prefs(geometry) 300x200
set prefs(isMaximized) false
## -- Private variables
variable tbSepNum 0
variable tbBtnNum 0
##
## Create the menu
##
. configure -menu .appframeMenu
set menu [menu .appframeMenu]
##
## Procedures
##
## -- Utility proc to easily insert a stub
proc stub {msg} {
tk_messageBox -message $msg -title "STUB"
}
## -- An exit procedure that saves preferences and exits
proc exitwrapper {{handler ""}} {
# handler is the user's exit handler
if {$handler != ""} {
eval $handler
}
appframe::SavePrefs
exit
}
## -- Main proc -- make an app frame
#
# Switches:
# -icon name of an .ico file
# -title title of the application
# -exitproc user-defned exit handler (called before saving preferences)
# -statusrelief relief for status area (e.g., flat, sunken, groove)
#
proc make {args} {
variable toolbar
variable main
variable title
variable statusbar
variable exitproc
set statusrelief flat
foreach {opt val} $args {
switch -exact -- $opt {
-icon {wm iconbitmap . -default $val}
-title {set title $val}
-exitproc {set exitproc "appframe::exitwrapper $val"}
-statusrelief {set statusrelief $val}
}
}
wm title . $title
# Put the exitproc action in 2 places -- "x" button and keyboard shortcut
wm protocol . WM_DELETE_WINDOW $exitproc
bind . <Control-q> $exitproc
## Toolbar
set toolbar [frame .appFrameToolbar]
grid .appFrameToolbar -row 0 -sticky ew -columnspan 2
## Status bar & resizer
set statusbar [frame .appFrameStatus -height 10]
grid .appFrameStatus -row 2 -sticky ew
label .appFrameStatus.announce -textvariable appframe::status -anchor w \
-relief $statusrelief
pack .appFrameStatus.announce -side left -fill x -expand yes
# Make this the same size as the resizer to give it room
frame .appFrameStatus.resizer -width 16 -height 16
pack .appFrameStatus.resizer -side right
sizer::sizer .
## Main app space
set main [frame .appFrameMain]
grid .appFrameMain -row 1 -sticky nsew
## Application grid
grid rowconfig . 1 -weight 1
grid columnconfig . 0 -weight 1
}
## -- Convenience proc to clear the status bar text variable
proc clearStatus {} {
variable status
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
#
proc addButton {args } {
variable toolbar
variable tbBtnNum
set button afBtn$tbBtnNum
incr tbBtnNum
set retval [button $toolbar.$button -relief flat -borderwidth 1]
pack $toolbar.$button -side left
set descr ""
set shortdescr ""
set command "appframe::stub $button"
set image ""
foreach {opt val} $args {
switch -exact -- $opt {
-imagedata {set image [image create photo -data $appframe::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
}
$toolbar.$button config -image $image
$toolbar.$button config -command $command
bind $toolbar.$button <Enter> "set appframe::status \"$descr\"; if {\[%W cget -state\] == \"normal\"} {%W configure -relief raised}"
bind $toolbar.$button <Leave> "set appframe::status \"\"; %W configure -relief flat"
if {$shortdescr != ""} {
appframe::balloonhelp::set_balloon $toolbar.$button "$shortdescr"
}
return $retval
}
## -- Proc to add a separator to the toolbar
proc addSep {} {
variable tbSepNum
variable toolbar
frame $toolbar.sep$tbSepNum -width 5 -borderwidth 0
pack $toolbar.sep$tbSepNum -side left -fill y -padx 4
incr tbSepNum
}
proc init {} {
variable title
LoadPrefs $title "prefs.tcl"
# Have to do this, at least in Windows, to ensure app has focus when started
focus -force .
}
##
## Manage Prefs
##
proc LoadPrefs {progname prefsfile} {
variable USERDIR
variable USERPREFS
variable prefs
variable appdir
# Get current user's home directory: If environment vars not available,
# default to subfolder of the installation folder
set USERDIR $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
}
}
proc SavePrefs {} {
variable prefs
variable USERDIR
variable USERPREFS
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)\""
}
close $fileID
}
}
namespace eval balloonhelp {
##############################################################################
# balloon.tcl - procedures used by balloon help
#
# Copyright (C) 1996-1997 Stewart Allen
#
# This is part of vtcl source code
# Adapted for general purpose by
# Daniel Roche <[email protected]>
# thanks to D. Richard Hipp for the multi-headed display fix
# version 1.2 ( Sep 21 2000 )
#
# This program 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
# of the License, or (at your option) any later version.
#
# This program 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 this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
##############################################################################
bind Bulle <Enter> {
set appframe::balloonhelp::Bulle(set) 0
set appframe::balloonhelp::Bulle(first) 1
set appframe::balloonhelp::Bulle(id) [after 500 {appframe::balloonhelp::balloon %W $Bulle(%W) %X %Y}]
}
bind Bulle <Button> {
set appframe::balloonhelp::Bulle(first) 0
appframe::balloonhelp::kill_balloon
}
bind Bulle <Leave> {
set appframe::balloonhelp::Bulle(first) 0
appframe::balloonhelp::kill_balloon
}
bind Bulle <Motion> {
if {$appframe::balloonhelp::Bulle(set) == 0} {
after cancel $appframe::balloonhelp::Bulle(id)
set appframe::balloonhelp::Bulle(id) [after 500 {appframe::balloonhelp::balloon %W $appframe::balloonhelp::Bulle(%W) %X %Y}]
}
}
proc set_balloon {target message} {
variable Bulle
set Bulle($target) $message
bindtags $target "[bindtags $target] Bulle"
}
proc kill_balloon {} {
variable Bulle
after cancel $Bulle(id)
if {[winfo exists .balloon] == 1} {
destroy .balloon
}
set Bulle(set) 0
}
proc balloon {target message {cx 0} {cy 0} } {
variable Bulle
if {$Bulle(first) == 1 } {
set Bulle(first) 2
if { $cx == 0 && $cy == 0 } {
set x [expr [winfo rootx $target] + ([winfo width $target]/2)]
set y [expr [winfo rooty $target] + [winfo height $target] + 4]
} else {
set x [expr $cx + 4]
set y [expr $cy + 4]
}
toplevel .balloon -bg black -screen [winfo screen $target]
wm overrideredirect .balloon 1
label .balloon.l \
-text $message -relief flat \
-bg #ffffaa -fg black -padx 2 -pady 0 -anchor w
pack .balloon.l -side left -padx 1 -pady 1
wm geometry .balloon +${x}+${y}
set Bulle(set) 1
}
}
}
namespace eval sizer {
######################################################################
#
# From [email protected] (from "sizer control" on the 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
}
}Here's an application that uses the framework. This is actually the program I used to create the base64-encoded button strings that appear in the code above, so it is hopefully useful by itself.
A couple of things to notice in the code:
- Any values assigned to the "prefs" array will be automatically saved on exit and retrieved when the program is restarted
- Balloon help can be applied to widgets in your own program, not just to the toolbar
- The variables "copyBtn" and "openBtn" aren't used here, but they could be used, e.g.l
if 0 {
$copyBtn config -state disabled
}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. Try it with this: 
.
Here's the application itself:
package require base64
## -- Do this before making the GUI
source "AppFrame.tcl"
appframe::make -title "Translate Gif" -statusrelief groove
## -- Set any preferences
set appframe::prefs(folder) $appframe::appdir
## -- Init will load preferences and set the focus
appframe::init
## -- Create the GUI
$appframe::menu add cascade -label "File" -menu $appframe::menu.file
menu $appframe::menu.file -tearoff false
$appframe::menu.file add command -label "Open" -command FindFile
$appframe::menu.file add command -label "Exit" -command $appframe::exitproc \
-underline 1 -accelerator "Ctrl+Q"
set openBtn [appframe::addButton -imagedata open -descr "Browse for a GIF file" \
-shortdescr "Find file" -command FindFile]
set copyBtn [appframe::addButton -imagedata copy -descr "Copy base64-encoded string" \
-shortdescr "Copy encoded image" -command CopyAll]
# Interface
text $appframe::main.t -height 1
pack $appframe::main.t -side top -expand yes -fill both
frame $appframe::main.f
pack $appframe::main.f -fill x -side top
label $appframe::main.f.l -text "File: "
pack $appframe::main.f.l -side left
entry $appframe::main.f.e -textvariable filename
pack $appframe::main.f.e -side left -expand yes -fill x
button $appframe::main.f.b -text "Browse..." -command FindFile
pack $appframe::main.f.b
# A button to put the image preview in
image create photo sampleImg
frame $appframe::main.fi
pack $appframe::main.fi -fill x -padx 2 -pady 4
label $appframe::main.fi.trans -text "Transparent color: "
pack $appframe::main.fi.trans -side left
label $appframe::main.fi.rl -text " R"
pack $appframe::main.fi.rl -side left
entry $appframe::main.fi.r -width 4 -textvariable appframe::prefs(red)
pack $appframe::main.fi.r -side left
label $appframe::main.fi.gl -text " G"
pack $appframe::main.fi.gl -side left
entry $appframe::main.fi.g -width 4 -textvariable appframe::prefs(green)
pack $appframe::main.fi.g -side left
label $appframe::main.fi.bl -text " B"
pack $appframe::main.fi.bl -side left
entry $appframe::main.fi.b -width 4 -textvariable appframe::prefs(blue)
pack $appframe::main.fi.b -side left
button $appframe::main.fi.i -image sampleImg -activebackground red -width 22 -height 22
pack $appframe::main.fi.i -side right -anchor e
appframe::balloonhelp::set_balloon $appframe::main.fi.i "Press to check transparency"
label $appframe::main.fi.preview -text "Preview: "
pack $appframe::main.fi.preview -side right -anchor e
## -- Commands
proc CopyAll {} {
$appframe::main.t tag remove sel 1.0 end
$appframe::main.t tag add sel 1.0 end
tk_textCopy $appframe::main.t
}
proc FindFile {} {
global filename
set filename [tk_getOpenFile -initialdir $appframe::prefs(folder) \
-filetypes {{{GIF files} {.gif} } {{All files} * }}]
if {$filename == ""} {return}
set appframe::prefs(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] != [$appframe::main.fi.r get]} {
set istcolor false
} elseif {[lindex $curcolor 1] != [$appframe::main.fi.g get]} {
set istcolor false
} elseif {[lindex $curcolor 2] != [$appframe::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
$appframe::main.t delete 1.0 end
$appframe::main.t insert end $encodedData
}