ulis, 2002-08-16, a little font chooser, tested under win2k only.
###############################
#
# a pure Tcl/Tk font chooser
#
# by ulis, 2002
#
# NOL (No Obligation Licence)
#
###############################
namespace eval ::choosefont \
{
variable w .choosefont
variable font
variable listvar [font families]
variable family
variable size
variable bold
variable italic
variable underline
variable overstrike
variable ok
variable lock 1
# ================
# choose a font
# ================
# args:
# f an initial (and optional) font
# t an optional title
# returns:
# "" if the user aborted
# or the created font name
# usage:
# namespace import ::choosefont::choosefont
# choosefont "Courier 10 italic" "new font"
namespace export choosefont
proc choosefont {{f ""} {t ""}} \
{
# ------------------
# get choosefont env
# ------------------
variable ::choosefont::w
variable ::choosefont::font
variable ::choosefont::listvar
variable ::choosefont::family
variable ::choosefont::size
variable ::choosefont::bold
variable ::choosefont::italic
variable ::choosefont::underline
variable ::choosefont::overstrike
variable ::choosefont::ok
variable ::choosefont::lock
# ------------------
# dialog
# ------------------
if {[winfo exists $w]} \
{ # show the dialog
wm deiconify $w
} \
else \
{ # create the dialog
toplevel $w
wm title $w "Choose a font"
# create widgets
frame $w.f -bd 1 -relief sunken
label $w.f.h -height 4
label $w.f.l -textvariable ::choosefont::family
frame $w.fl
listbox $w.fl.lb -listvar ::choosefont::listvar -width 20 \
-yscrollcommand [list $w.fl.sb set]
scrollbar $w.fl.sb -command [list $w.fl.lb yview]
frame $w.fa -bd 2 -relief groove
frame $w.fa.f
label $w.fa.f.lsize -text size
entry $w.fa.f.esize -textvariable ::choosefont::size -width 3 \
-validate focusout -vcmd {string is integer -strict %P}
checkbutton $w.fa.f.bold -text bold \
-variable ::choosefont::bold
checkbutton $w.fa.f.italic -text italic \
-variable ::choosefont::italic
checkbutton $w.fa.f.under -text underline \
-variable ::choosefont::underline
checkbutton $w.fa.f.over -text overstrike \
-variable ::choosefont::overstrike
frame $w.fb
button $w.fb.ok -text Ok -width 10 \
-command { set ::choosefont::ok 1 }
button $w.fb.cancel -text cancel -width 10 \
-command { set ::choosefont::ok 0 }
# bind events
bind $w.fl.lb <ButtonRelease-1> \
{ set ::choosefont::family [%W get [%W cursel]] }
set lock 1
trace variable ::choosefont::family w ::choosefont::createfont
trace variable ::choosefont::size w ::choosefont::createfont
trace variable ::choosefont::bold w ::choosefont::createfont
trace variable ::choosefont::italic w ::choosefont::createfont
trace variable ::choosefont::underline w ::choosefont::createfont
trace variable ::choosefont::overstrike w ::choosefont::createfont
# place widgets
grid $w.f -row 0 -column 0 -columnspan 2 -sticky nsew
grid $w.fl -row 1 -column 0 -padx 5 -pady 5
grid $w.fa -row 1 -column 1 -sticky nsew -padx 5 -pady 5
grid $w.fb -row 2 -column 0 -columnspan 2 -sticky ew -pady 20
grid $w.f.h -row 0 -column 0
grid $w.f.l -row 0 -column 1 -sticky nsew
grid $w.fl.lb -row 0 -column 0
grid $w.fl.sb -row 0 -column 1 -sticky ns
grid $w.fa.f -padx 5 -pady 5
grid $w.fa.f.lsize -row 0 -column 0 -padx 5 -sticky w
grid $w.fa.f.esize -row 0 -column 1 -sticky w
grid $w.fa.f.bold -row 1 -column 0 -columnspan 2 -sticky w
grid $w.fa.f.italic -row 2 -column 0 -columnspan 2 -sticky w
grid $w.fa.f.under -row 3 -column 0 -columnspan 2 -sticky w
grid $w.fa.f.over -row 4 -column 0 -columnspan 2 -sticky w
grid $w.fb.ok $w.fb.cancel -padx 20
}
# ------------------
# current font
# ------------------
if {$f != ""} { set font $f }
if {![info exists font]} { set font [$w.f.l cget -font] }
set family [font actual $font -family]
set size [font actual $font -size]
set bold [expr {[font actual $font -weight] == "bold"}]
set italic [expr {[font actual $font -slant] == "italic"}]
set underline [font actual $font -underline]
set overstrike [font actual $font -overstrike]
set lock 0
::choosefont::createfont
# ------------------
# end of dialog
# ------------------
if {$t != ""} { wm title $w $t }
vwait ::choosefont::ok
wm withdraw $w
if {$ok} { return [::choosefont::createfont] } \
else { return "" }
}
# ================
# ancillary procs
# ================
proc createfont {args} \
{
if {$::choosefont::lock} { return }
variable ::choosefont::w
variable ::choosefont::font
variable ::choosefont::family
variable ::choosefont::size
variable ::choosefont::bold
variable ::choosefont::italic
variable ::choosefont::underline
variable ::choosefont::overstrike
catch { font delete $font }
set f [list -family $family -size $size]
foreach {var option value} {bold -weight bold
italic -slant italic
underline -underline 1
overstrike -overstrike 1} \
{ if {[set $var]} { lappend f $option $value } }
set font [eval font create $f]
$w.f.l config -font $font
return $font
}
}
# test
if 0 \
{
namespace import ::choosefont::choosefont
choosefont "Courier 10 italic" "new font"
}