LES on 2003-09-28 - Works for me on Win 98.Googie, 2005-05-07, under X11 (Linux) looks fine too.The chooser
###############################
#
# a pure Tcl/Tk font chooser
#
# by ulis, 2002
#
# NOL (No Obligation Licence)
#
###############################
namespace eval ::choosefont \
{
variable w .choosefont;
variable font;
# Martin Lemburg Aug. 20th, 2002
# initialization moved into proc choosefont
#
variable listvar;
#
# Martin Lemburg Aug. 20th, 2002
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;
# Martin Lemburg Aug. 20th, 2002
# refreshing, with every call, lsort added
#
set listvar [lsort -dictionary [font families]];
#
# Martin Lemburg Aug. 20th, 2002
# ------------------
# 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;
# Martin Lemburg Aug. 20th, 2002
# added selectmode setting
#
listbox $w.fl.lb \
-listvar ::choosefont::listvar \
-width 20 \
-yscrollcommand [list $w.fl.sb set] \
-selectmode single;
#
# Martin Lemburg Aug. 20th, 2002
scrollbar $w.fl.sb -command [list $w.fl.lb yview];
# Martin Lemburg Aug. 20th, 2002
# added underline options for mnemonics
#
frame $w.fa -bd 2 -relief groove;
frame $w.fa.f ;
label $w.fa.f.lsize -text size -underline 0;
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 \
-underline 0 \
-variable ::choosefont::bold;
checkbutton $w.fa.f.italic -text italic \
-underline 0 \
-variable ::choosefont::italic;
checkbutton $w.fa.f.under \
-text underline \
-underline 0 \
-variable ::choosefont::underline;
checkbutton $w.fa.f.over \
-text overstrike \
-underline 0 \
-variable ::choosefont::overstrike;
#
# Martin Lemburg Aug. 20th, 2002,
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]] };
# Martin Lemburg Aug. 20th, 2002
# extended bindings
#
tk_focusFollowsMouse;
# listbox handling
bind $w <Control-Home> \
{ ::choosefont::selectfont %W First };
bind $w <Control-End> \
{ ::choosefont::selectfont %W Last };
bind $w <KeyPress> \
{ ::choosefont::selectfont %W %K };
bind $w <Escape> [list $w.fb.cancel invoke];
bind $w <Return> [list $w.fb.ok invoke];
# mnemonics
bind $w <Alt-KeyRelease> \
{
set w [winfo toplevel %W];
switch -exact -- [string tolower %K] \
{
s {focus $w.fa.f.esize;}
b {focus $w.fa.f.bold; $w.fa.f.bold invoke;}
i {focus $w.fa.f.italic; $w.fa.f.italic invoke;}
u {focus $w.fa.f.under; $w.fa.f.under invoke;}
o {focus $w.fa.f.over; $w.fa.f.over invoke;}
}
}
#
# Martin Lemburg Aug. 20th, 2002
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 };
# Martin Lemburg Aug. 20th, 2002 - select current font
#
set newIndex [lsearch -exact $listvar $family];
$w.fl.lb selection set $newIndex;
$w.fl.lb activate $newIndex;
$w.fl.lb see $newIndex;
#
# Martin Lemburg Aug. 20th, 2002
vwait ::choosefont::ok;
wm withdraw $w;
if {$ok} \
{ return [::choosefont::createfont] } \
else \
{ return "" };
};
# ================
# ancillary procs
# ================
proc selectfont {w mode} \
{
if {[winfo class $w] != "Listbox"} \
{ return; }
set oldIndex [$w curselection];
if {[string length $mode] > 1} \
{
switch -exact -- $mode \
{
Down {set newIndex [expr {$oldIndex+1}];}
Up {set newIndex [expr {$oldIndex-1}];}
First {set newIndex 0;}
Last {set newIndex end;}
default \
{ return; }
}
if {($newIndex != "end") && $newIndex} \
{
if {$newIndex < 0} \
{ set newIndex 0; } \
elseif {$newIndex > [$w size] - 1} \
{ set newIndex end; };
}
} \
else \
{
set oldFamily [lindex $::choosefont::listvar $oldIndex];
if {[string match ${mode}* $oldFamily]} \
{
set newIndex [expr {$oldIndex + 1}];
set newFamily [lindex $::choosefont::listvar $newIndex];
if {![string match ${mode}* $newFamily]} \
{
set newIndex [lsearch \
-glob \
$::choosefont::listvar \
${mode}* \
];
}
} \
else \
{
set newIndex [lsearch \
-glob \
$::choosefont::listvar \
${mode}* \
];
};
if {$newIndex < 0} \
{ return; };
};
set ::choosefont::family [$w get $newIndex];
$w selection clear $oldIndex;
$w selection set $newIndex;
$w activate $newIndex;
$w see $newIndex;
return;
}
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 } };
$w.f.l config -font [set font [eval font create $f]];
return $font;
}
}A demo
# test namespace import ::choosefont::choosefont choosefont "Courier 10 italic" "new font"
ImprovementsMartin Lemburg August 20th, 2002: beautified a little bit by adding:
- mnemomic bindings, e.g. Alt+b -> bold
- keyboard bindings to the listbox, like cursor bindings and alphabetic bindings to jump quicker to a known font family by typing the first character
- the Return- and Escape-binding for ok and cancel
- a sorting of the font family list and a refresh of the font family list everytime the font chooser is called
DiscussionJust a quick observation/question. Since newbies are going to be looking at the code, shouldn't the wiki adhere to the Tcl coding style and not breaking lines with slashes to do brace placing?ulis Your (anonymous) Tcl coding style is Kerningham's C style and I don't know any standard style for Tcl. I think the style I used is best suited for beginners showing clearly where blocs begin and end.RLH Can I agree with both? I would note that the books I have read and the documentation do not show the coding style above. So maybe that is what the poster meant by Tcl coding style.MG Personally, I don't use that coding style (braces on the next line) like ulis does, and I'm still never quite familiar with it when I see it. But I don't think it can hurt having different styles on the Wiki; if you're serious about programming in Tcl (or any other language, for that matter), you're going to have to get used to seeing a LOT of different coding styles. No two people write code in the same way. Though, they should, since my coding style is obviously better than any other... ;)-- Well i am one of the newbies, and am curious, how this scripts finds out about the fonts on my linux machine? Which code part is it?RS: font families returns a list of all available fonts.- Another note: trailing semicolons are redundant in Tcl, and snippets like this
if {$newIndex < 0} \
{ return; };
};can much simpler, and more idiomatically, be written as if {$newIndex < 0} returnWe should be glad that Tcl is not C :-)GN i use semicolons quite often in Tcl to allow multiple commands on one line (puts 1; puts 2; puts 3)RS True. But semicolons are statement separators in Tcl (just like newline), so to put them behind non-multiple commands is redundant.Zipguy 2013-09-01 - You can find out my email address by clicking on Zipguy. I downloaded the first file and it did work pretty well, even on Windows 7, which I'm using. I fixed the screenshot above.It only shows a text entry field which lets you type in a number.What you might like better is on the "Font Choosers" page
Googie 2005-05-07 What about to change entry into spinbox from Tcl/Tk 8.4? Would be much more usable.
schlenk 2005-09-19 My version of this font chooser, with tile and msgcat support added and the controversial brace and semicolons removed.
###############################
#
# a pure Tcl/Tk font chooser
#
# by ulis, 2002
#
# NOL (No Obligation Licence)
#
#
# Basic Tile'ification and msgcat support
# by schlenk, 2005
###############################
package require Tcl 8.4
package require Tk 8.4
package require msgcat
package require tile 0.6
namespace eval ::choosefont {
namespace import ::msgcat::mc
namespace import ::ttk::*
variable w .choosefont
variable font
# Martin Lemburg Aug. 20th, 2002
# initialization moved into proc choosefont
#
variable listvar
#
# Martin Lemburg Aug. 20th, 2002
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
# Martin Lemburg Aug. 20th, 2002
# refreshing, with every call, lsort added
#
set listvar [lsort -dictionary [font families]]
#
# Martin Lemburg Aug. 20th, 2002
# ------------------
# dialog
# ------------------
if {[winfo exists $w]} {
# show the dialog
wm deiconify $w
} else {
# create the dialog
toplevel $w
wm title $w [mc "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
# Martin Lemburg Aug. 20th, 2002
# added selectmode setting
#
listbox $w.fl.lb \
-listvar ::choosefont::listvar \
-width 20 \
-yscrollcommand [list $w.fl.sb set] \
-selectmode single
#
# Martin Lemburg Aug. 20th, 2002
scrollbar $w.fl.sb -command [list $w.fl.lb yview]
# Martin Lemburg Aug. 20th, 2002
# added underline options for mnemonics
#
frame $w.fa -bd 2 -relief groove
frame $w.fa.f
label $w.fa.f.lsize -text [mc size] -underline 0
spinbox $w.fa.f.esize \
-textvariable ::choosefont::size \
-width 3 \
-validate focusout \
-vcmd {string is integer -strict %P} \
-from 1 \
-to 500
checkbutton $w.fa.f.bold \
-text [mc bold] \
-underline 0 \
-variable ::choosefont::bold
checkbutton $w.fa.f.italic -text [mc italic] \
-underline 0 \
-variable ::choosefont::italic
checkbutton $w.fa.f.under \
-text [mc underline] \
-underline 0 \
-variable ::choosefont::underline
checkbutton $w.fa.f.over \
-text [mc overstrike] \
-underline 0 \
-variable ::choosefont::overstrike
#
# Martin Lemburg Aug. 20th, 2002,
frame $w.fb
button $w.fb.ok \
-text [mc Ok] \
-width 10 \
-command { set ::choosefont::ok 1 }
button $w.fb.cancel \
-text [mc cancel] \
-width 10 \
-command { set ::choosefont::ok 0 }
# bind events
bind $w.fl.lb <ButtonRelease-1> \
{ set ::choosefont::family [%W get [%W cursel]] }
# listbox handling
bind $w <Control-Home> \
{ ::choosefont::selectfont %W First }
bind $w <Control-End> \
{ ::choosefont::selectfont %W Last }
bind $w <KeyPress> \
{ ::choosefont::selectfont %W %K }
bind $w <Escape> [list $w.fb.cancel invoke]
bind $w <Return> [list $w.fb.ok invoke]
# mnemonics
bind $w <Alt-KeyRelease> {
set w [winfo toplevel %W]
switch -exact -- [string tolower %K] {
s {focus $w.fa.f.esize}
b {focus $w.fa.f.bold $w.fa.f.bold invoke}
i {focus $w.fa.f.italic $w.fa.f.italic invoke}
u {focus $w.fa.f.under $w.fa.f.under invoke}
o {focus $w.fa.f.over $w.fa.f.over invoke}
}
}
#
# Martin Lemburg Aug. 20th, 2002
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 -pady {2 20}
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 -pady 3
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 }
# Martin Lemburg Aug. 20th, 2002 - select current font
#
set newIndex [lsearch -exact $listvar $family]
$w.fl.lb selection set $newIndex
$w.fl.lb activate $newIndex
$w.fl.lb see $newIndex
#
# Martin Lemburg Aug. 20th, 2002
vwait ::choosefont::ok
wm withdraw $w
if {$ok} {
return [::choosefont::createfont]
} else {
return ""
}
}
# ================
# ancillary procs
# ================
proc selectfont {w mode} \
{
if {[winfo class $w] != "Listbox"} { return }
set oldIndex [$w curselection]
if {[string length $mode] > 1} {
switch -exact -- $mode \
{
Down {set newIndex [expr {$oldIndex+1}]}
Up {set newIndex [expr {$oldIndex-1}]}
First {set newIndex 0}
Last {set newIndex end}
default { return }
}
if {($newIndex ne "end") && $newIndex} {
if {$newIndex < 0} {
set newIndex 0
} elseif {$newIndex > [$w size] - 1} {
set newIndex end
}
}
} else {
set oldFamily [lindex $::choosefont::listvar $oldIndex]
if {[string match ${mode}* $oldFamily]} {
set newIndex [expr {$oldIndex + 1}]
set newFamily [lindex $::choosefont::listvar $newIndex]
if {![string match ${mode}* $newFamily]} {
set newIndex [lsearch \
-glob \
$::choosefont::listvar \
${mode}* \
]
}
} else {
set newIndex [lsearch \
-glob \
$::choosefont::listvar \
${mode}* \
]
}
if {$newIndex < 0} { return }
}
set ::choosefont::family [$w get $newIndex]
$w selection clear $oldIndex
$w selection set $newIndex
$w activate $newIndex
$w see $newIndex
return
}
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 } }
$w.f.l config -font [set font [eval [linsert $f 0 font create]]]
return $font
}
}
package provide choosefont 0.1
# some translations for the msgcat support
namespace eval ::choosefont {
namespace import ::msgcat::mcset
namespace import ::msgcat::mcset
mcset de "ok" "Ok"
mcset de "cancel" "Abbrechen"
mcset de "bold" "Fett"
mcset de "italic" "Kursiv"
mcset de "underline" "Unterstrichen"
mcset de "overstrike" "Durchgestrichen"
mcset de "size" "Größe"
mcset de "Choose a font" "Schriftart auswählen"
}WJP I recently made a font selection widget that has a somewhat different philosophy from others that I have seen. The code is too long to put up here (both intriniscally and because the demo won't run without some ancillary stuff such as balloon help), so I've made the code available at: http://billposer.org/Software/FontControl.tcl
. Here's a screenshot showing what the control panel looks like:
The top section illustrates the main difference in philosophy. Instead of selecting a font and then using it as desired, the idea here is that you first decide what distinct fonts you want to have (that is, say, one for most text, another for help balloons, another for menu labels, etc.) and make a list of them. The control panel then presents you with a menu of fonts that you can configure. (It actually is possible to call my procedure with an argument naming the single font you want to configure, but that isn't the usual intended use.)A second idea is that it is helpful to be able to contrast the existing font with the candidate for replacing it.A third idea is that a font that looks good with one color scheme may be illegible in another, so I provide color adjustment so that you can view the candidate and current fonts in the colors that you are thinking of.A fourth idea is that it is nice to have a way to return to default values after you've played around. There's a procedure for recording defaults (since you may want to record them after, let's say, the program has read its init file), and a button for resetting the font to the default values.The package provides some ancillary procedures that aren't called in the demo. DefineFontSettingProcs creates procedures for setting fonts and their properties suitable for exposing in a slave interpreter used to read a configuration file. AliasFontSettings takes care of aliasing these procedures in a specified slave interpreter. SaveFontSettings is useful if you want to save the current settings.Oct-08-2005 There is also a font selection dialogue by dkf. Look at http://people.man.ac.uk/~zzcgudf/tcl/mwidx.html#fontdlg
See also fontview as eTcl plugin