Tcl/Tk Sample Application (font chooser)
#!/usr/bin/wish -f
# OK button callback. Get the string from getXLFD and write it out.
# The empty {} is where the parameters would go if there were any.
proc ok {} {
puts [getXLFD]
exit
}
# build up the XLFD string and return it
proc getXLFD {} {
global bold italic fontsize
set fstring ""
set facename [.fontname get [.fontname curselection]]
if {$bold} {
set fstring "*-$facename-bold"
} else {
set fstring "*-$facename-medium"
}
if {$italic} {
if {$facename == "Helvetica" || $facename == "Courier"} {
set fstring "$fstring-o-normal--$fontsize-*"
} else {
set fstring "$fstring-i-normal--$fontsize-*"
}
} else {
set fstring "$fstring-r-normal--$fontsize-*"
}
return $fstring
}
# reset the font resource of the preview widget
proc resetFont {} {
.preview configure -font [getXLFD]
}
# Scrollbar callback, y is either -1 or 1 depending on whether the
# up arrow or down arrow was pressed
proc changeSize y {
global fontsize
# use regular expression to verify that font size field is a number
if [regexp {^[0-9]+$} $fontsize] {
set fontsize [expr $fontsize-$y]
}
else {
set fontsize 1
}
# can't call resetFont here, since Tk generates errors if a font
# that doesn't exist is requested (unlike the other two tools).
}
# help button (F1) callback
proc help {} {
puts "no built-in help support"
}
# add this font to the option database Tk uses to determine what
# attributes each of the widgets have (this could have also been done
# using the .Xdefaults file).
option add *font -adobe-helvetica-medium-r-normal--14-140-75-75-p-77-iso8859-1
# tell the window manager how big to make the window (. is main window
# for our application)
wm geometry . 346x334
# global binding of F1 key to the help function
bind all <KeyPress-F1> help
# Create a label widget
label .namel -text "Name:"
# Widget placement is done with the "Placer" geometry manager, since
# that supports exact positioning. The "Packer", while more powerful
# and more commonly used, uses a geometry management technique that
# makes layout of irregular dialogs like this one more difficult
place .namel -x 8 -y 4 -width 64 -height 32
# There is no scrolling list box in Tk, so create a list box and a
# scrollbar and attach them to each other by setting the commands
# appropriately
listbox .fontname -relief sunken -yscrollcommand ".fnsb set"
scrollbar .fnsb -relief sunken -command ".fontname yview"
place .fontname -x 16 -y 36 -width 184 -height 140
place .fnsb -x 200 -y 36 -width 16 -height 140
# Insert the font names into the list box
foreach name {Charter Clean Courier Helvetica Lucida LucidaBright\
LucidaTypewriter {New Century Schoolbook} Symbol Times\
fixed terminal} {
.fontname insert end $name
}
# no option to be notified when a list item is selected,
# so bind it to the raw button event
bind .fontname <ButtonRelease-1> resetFont
label .sizel -text "Size:"
place .sizel -x 224 -y 40 -width 48 -height 32
# Make a global variables to attach to the entry widget
set fontsize 14
# no way be notified when another entry is selected
# so preview won't change if size is entered manually
entry .fontsize -relief sunken -textvariable fontsize
place .fontsize -x 272 -y 40 -width 40 -height 32
scrollbar .sb -command changeSize
place .sb -x 312 -y 36 -width 22 -height 40
label .stylel -text "Style:"
place .stylel -x 224 -y 104 -width 52 -height 32
# Make global variables to attach to the checkbuttons
set bold 0
set italic 0
checkbutton .bold -text "Bold" -variable bold -command resetFont
place .bold -x 276 -y 104 -width 60 -height 28
checkbutton .italic -text "Italic" -variable italic -command resetFont
place .italic -x 276 -y 132 -width 60 -height 28
label .previewl -text "Preview:"
place .previewl -x 12 -y 200 -width 76 -height 32
set previewtext "Sample text"
entry .preview -relief sunken -textvariable previewtext
place .preview -x 84 -y 200 -width 246 -height 72
# no way to make buttons have the "default" look and behavior
# so leave it out
button .ok -text "OK" -command ok
place .ok -x 13 -y 288 -width 96 -height 36
# attach the exit command directly to widget, no need for a function
button .cancel -text "Cancel" -command exit
place .cancel -x 129 -y 288 -width 96 -height 36
button .help -text "Help" -command help
place .help -x 238 -y 288 -width 96 -height 36