Keith Vetter 20060622 : Here's yet another Font Chooser Dialog.
I didn't like any of the existing ones: A little font chooser, A small font chooser, Font selector program (Raney) and one by DKF at http://people.man.ac.uk/~zzcgudf/tcl/mwidx.html#fontdlg . What I really wanted is the native Windows ChooseFont dialog, but that's still on the wish list.
So, here's my version of the font chooser dialog which tries to emulate the native Windows dialog closely. It will use the tile package if present (and looks much better).
MG As someone who's only ever really used Windoze, I think this is probably (one of) the best looking font selection widgets I've seen. Two things that would be nice additions, though:
(One other thing I noticed is that the borders on the labelframes for Effects/Sample go very close to the labels themselves - there's usually a small amount of padding around the text, I think? - though I suspect that's something that stems from Tile, as opposed to this code specifically.)
Even without those features, this is very nice. Thanks for sharing it, Keith :) Now I just need to find time to update the font selectors in all my apps...
KPV Two good points. For the first, I deliberately disabled typing in data for this version because I needed something fast. Getting all the details right is tricky.
For the mousewheel, take a look at tip 171. That code will make the mousewheel work like you expect it to--actually it will work better than Microsoft's dialog. (NB. to get tip 171 to work with tile's scrollbar, you have to modify the code to recognize "TScrollbar".)
##+########################################################################## # # ::ChooseFont -- yet another font chooser dialog # by Keith Vetter, June 2006 # # usage: set font [::ChooseFont::ChooseFont] # usage: set font [::ChooseFont::ChooseFont "Helvetica 8 italic"] # package require Tk catch {package require tile} ;# Not needed, but looks better namespace eval ::ChooseFont { variable S set S(W) .cfont set S(fonts) [lsort -dictionary [font families]] set S(styles) {Regular Italic Bold "Bold Italic"} set S(sizes) {8 9 10 11 12 14 16 18 20 22 24 26 28 36 48 72} set S(strike) 0 set S(under) 0 set S(first) 1 } proc ::ChooseFont::ChooseFont {{defaultFont ""}} { variable S destroy $S(W) toplevel $S(W) -padx 10 -pady 10 wm title $S(W) "Font" set tile [expr {[catch {package present tile}] ? "" : "::ttk"}] ${tile}::label $S(W).font -text "Font:" ${tile}::label $S(W).style -text "Font style:" ${tile}::label $S(W).size -text "Size:" entry $S(W).efont -textvariable ::ChooseFont::S(font) -state disabled entry $S(W).estyle -textvariable ::ChooseFont::S(style) -state disabled entry $S(W).esize -textvariable ::ChooseFont::S(size) -width 0 -state disabled set bg [$S(W).efont cget -bg] set fg [$S(W).efont cget -fg] $S(W).efont config -disabledbackground $bg -disabledforeground $fg $S(W).estyle config -disabledbackground $bg -disabledforeground $fg $S(W).esize config -disabledbackground $bg -disabledforeground $fg ${tile}::button $S(W).ok -text OK -command [list ::ChooseFont::Done 1] ${tile}::button $S(W).cancel -text Cancel -command [list ::ChooseFont::Done 0] wm protocol $S(W) WM_DELETE_WINDOW [list ::ChooseFont::Done 0] ${tile}::scrollbar $S(W).sbfonts -command [list $S(W).lfonts yview] listbox $S(W).lfonts -listvariable ::ChooseFont::S(fonts) -height 7 \ -yscroll [list $S(W).sbfonts set] -height 7 -exportselection 0 listbox $S(W).lstyles -listvariable ::ChooseFont::S(styles) -height 7 ${tile}::scrollbar $S(W).sbsizes -command [list $S(W).lsizes yview] listbox $S(W).lsizes -listvariable ::ChooseFont::S(sizes) \ -yscroll [list $S(W).sbsizes set] -width 6 -height 7 -exportselection 0 bind $S(W).lfonts <<ListboxSelect>> [list ::ChooseFont::Click font] bind $S(W).lstyles <<ListboxSelect>> [list ::ChooseFont::Click style] bind $S(W).lsizes <<ListboxSelect>> [list ::ChooseFont::Click size] grid $S(W).font - x $S(W).style - x $S(W).size - x -sticky w grid $S(W).efont - x $S(W).estyle - x $S(W).esize - x $S(W).ok -sticky ew grid $S(W).lfonts $S(W).sbfonts x \ $S(W).lstyles - x \ $S(W).lsizes $S(W).sbsizes x \ $S(W).cancel -sticky news grid config $S(W).cancel -sticky n -pady 5 grid columnconfigure $S(W) {2 5 8} -minsize 10 grid columnconfigure $S(W) {0 3 6} -weight 1 set WE $S(W).effects ${tile}::labelframe $WE -text "Effects" ${tile}::checkbutton $WE.strike -variable ::ChooseFont::S(strike) \ -text Strikeout -command [list ::ChooseFont::Click strike] ${tile}::checkbutton $WE.under -variable ::ChooseFont::S(under) \ -text Underline -command [list ::ChooseFont::Click under] grid $WE.strike -sticky w -padx 10 grid $WE.under -sticky w -padx 10 grid columnconfigure $WE 1 -weight 1 grid $WE - x -sticky news -row 100 -column 0 set WS $S(W).sample ${tile}::labelframe $WS -text "Sample" label $WS.fsample -bd 2 -relief sunken label $WS.fsample.sample -text "AaBbYyZz" set S(sample) $WS.fsample.sample pack $WS.fsample -fill both -expand 1 -padx 10 -pady 10 -ipady 15 pack $WS.fsample.sample -fill both -expand 1 pack propagate $WS.fsample 0 grid rowconfigure $S(W) 2 -weight 1 grid rowconfigure $S(W) 99 -minsize 30 grid $WS - - - - -sticky news -row 100 -column 3 grid rowconfigure $S(W) 101 -minsize 30 ::ChooseFont::Init $defaultFont tkwait window $S(W) return $S(result) } proc ::ChooseFont::Done {ok} { if {! $ok} {set ::ChooseFont::S(result) ""} destroy $::ChooseFont::S(W) } proc ::ChooseFont::Init {{defaultFont ""}} { variable S if {$S(first) || $defaultFont ne ""} { if {$defaultFont eq ""} { set defaultFont [[entry .___e] cget -font] destroy .___e } array set F [font actual $defaultFont] set S(font) $F(-family) set S(size) $F(-size) set S(strike) $F(-overstrike) set S(under) $F(-underline) set S(style) "Regular" if {$F(-weight) eq "bold" && $F(-slant) eq "italic"} { set S(style) "Bold Italic" } elseif {$F(-weight) eq "bold"} { set S(style) "Bold" } elseif {$F(-slant) eq "italic"} { set S(style) "Italic" } set S(first) 0 } # Make selection in each listbox foreach var {font style size} { set n [lsearch -exact $S(${var}s) $S($var)] $S(W).l${var}s selection set $n $S(W).l${var}s see $n } ::ChooseFont::Click test } proc ::ChooseFont::Click {who} { variable S if {$who eq "font"} { set S(font) [$S(W).lfonts get [$S(W).lfonts curselection]] } elseif {$who eq "style"} { set S(style) [$S(W).lstyles get [$S(W).lstyles curselection]] } elseif {$who eq "size"} { set S(size) [$S(W).lsizes get [$S(W).lsizes curselection]] } set S(result) [list $S(font) $S(size)] if {$S(style) eq "Bold"} { lappend S(result) bold } if {$S(style) eq "Italic"} { lappend S(result) italic } if {$S(style) eq "Bold Italic"} { lappend S(result) bold italic} if {$S(strike)} { lappend S(result) overstrike} if {$S(under)} { lappend S(result) underline} set n [catch {$S(sample) config -font $S(result)} emsg] $S(W).ok config -state [expr {$n ? "disabled" : "normal"}] } # Quick test set font [::ChooseFont::ChooseFont "Arial 12 bold"] puts "font is '$font'" return
Category Example | Category Characters | Category GUI | Category Widget