This [Tk] command was added due to [TIP]#324 [http://tip.tcl.tk/324] ---- [ZB] What do you think about moving "OK" and "Cancel" buttons down, and place them horizontally, under "Effect"/"Sample" frames? Currently there's a whole lot of empty space on the right, due to buttons position. [DKF]: The current dialog has rather a lot more wrong with it than that. (For example, it's localization is utterly botched, its usability is substandard and its key bindings are incomplete.) I think the best phrase to use is “not yet fixed”. [HE] 2020-07-12: Some remarks from my side. First my opinion: I don't like that the dialog doesn't work as the other build in dialogs of Tk. I like it more to call a dialog and get a return value back as it is done by tk_getOpenFile or tk_chooseDirectory for example. Now what I found out about if it works on different platforms. If I use tk fontchooser on Windows 10, it use tthe OS internal font dialog. This works mainly as expected. This doesn't mean, that I have checked everything. The main caveat is that OS dialogs does not use the locale used by the program. They use the locale configured in the user profile. But, this is a problem which other dialogs have, too. I have no OS X systems so I can't check the behavior on such a system. On Linux and related OS a dialog implemented in Tcl is used. This dialog could be also used in the other OS by calling ::tk::fontchooser configure|show|hide. The problem with that is, that the implementation looks like it is stopped in between, as [DKF] mentioned before. There is a patch from 2008 which tries to fix it (https://core.tcl-lang.org/tk/tktview?name=2442314fff). This patch doesn't work any longer. But, the changes would not have been fix it completely. Non documented/not directly clear behaviour of the Tcl only version: * 'tk fontchooser hide' will withdraw the dialog. A call of 'tk fontchooser show' will then show it again. Locale are unchanged. * Button 'Ok' and 'Cancel' will destroy the dialog. * - Button 'Ok' and 'Apply' will provide the current selected font to the callback procedure. The dialog exists in lib/tk8.6/fontchooser.tcl of the installation. In the sources the file is in tk8.6.10/generic/. What doesn't work: Described by the supplier of the patch: * The Tcl implementation of fontchooser does not use the message catalog to display font styles. * Furthermore the label for the Font size uses the same width as the listbox that contains the numbers of the font sizes. This may not be wide enough for some languages like German for example. Found by me after applying the patch manually: * The locale of the style is set when fontchooser.tcl is sourced. Therefore, a locale change afterwards will not change the displayed style. All other strings use a changed locale when the dialog is new created. * The default value of style is not translated into the used locale. If the selected locale use different strings for the styles, you can't use the 'Ok' button but the 'Apply' button. * The provided font does not contain the style attributes in case of a locale like de. Reason is that the value is not translated back to the way Tk use it. I filled a ticket (https://core.tcl-lang.org/tk/tktview?name=1f46cac080) for that. The following is the contents of the fontchooser.tcl in Tk 8.6.10 updated to fix all the listed issues. It doesn't cleanup or improve the code. Simply replace the contents of the installed fontchooser.tcl with the below code (For sure it is a good idea to save the original file before): ====== # fontchooser.tcl - # # A themeable Tk font selection dialog. See TIP #324. # # Copyright (C) 2008 Keith Vetter # Copyright (C) 2008 Pat Thoyts # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. namespace eval ::tk::fontchooser { variable S set S(W) .__tk__fontchooser set S(fonts) [lsort -dictionary -unique [font families]] set S(styles) [list \ [::msgcat::mc "Regular"] \ [::msgcat::mc "Italic"] \ [::msgcat::mc "Bold"] \ [::msgcat::mc "Bold Italic"] \ ] set S(sizes) {8 9 10 11 12 14 16 18 20 22 24 26 28 36 48 72} set S(sizes,lcase) $S(sizes) set S(strike) 0 set S(under) 0 set S(first) 1 set S(sampletext) [::msgcat::mc "AaBbYyZz01"] set S(-parent) . set S(-title) [::msgcat::mc "Font"] set S(-command) "" set S(-font) TkDefaultFont set windowName __tk__fontchooser if {$S(-parent) eq "."} { set S(W) .$windowName } else { set S(W) $S(-parent).$windowName } } proc ::tk::fontchooser::Canonical {} { variable S # Canonical versions of font families, styles, etc. for easier searching set S(fonts,lcase) {} foreach font $S(fonts) {lappend S(fonts,lcase) [string tolower $font]} set S(styles,lcase) {} foreach style $S(styles) {lappend S(styles,lcase) [string tolower $style]} } proc ::tk::fontchooser::Setup {} { Canonical ::ttk::style layout FontchooserFrame { Entry.field -sticky news -border true -children { FontchooserFrame.padding -sticky news } } bind [winfo class .] <> \ [list +ttk::style layout FontchooserFrame \ [ttk::style layout FontchooserFrame]] namespace ensemble create -map { show ::tk::fontchooser::Show hide ::tk::fontchooser::Hide configure ::tk::fontchooser::Configure } } ::tk::fontchooser::Setup proc ::tk::fontchooser::Show {} { variable S set S(styles) [list \ [::msgcat::mc "Regular"] \ [::msgcat::mc "Italic"] \ [::msgcat::mc "Bold"] \ [::msgcat::mc "Bold Italic"] \ ] set S(sampletext) [::msgcat::mc "AaBbYyZz01"] set S(-title) [::msgcat::mc "Font"] set S(fonts) [lsort -dictionary -unique [font families]] Canonical if {![winfo exists $S(W)]} { Create wm transient $S(W) [winfo toplevel $S(-parent)] tk::PlaceWindow $S(W) widget $S(-parent) } wm deiconify $S(W) } proc ::tk::fontchooser::Hide {} { variable S wm withdraw $S(W) } proc ::tk::fontchooser::Configure {args} { variable S set specs { {-parent "" "" . } {-title "" "" ""} {-font "" "" ""} {-command "" "" ""} } if {[llength $args] == 0} { set result {} foreach spec $specs { foreach {name xx yy default} $spec break lappend result $name \ [expr {[info exists S($name)] ? $S($name) : $default}] } lappend result -visible \ [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}] return $result } if {[llength $args] == 1} { set option [lindex $args 0] if {[string equal $option "-visible"]} { return [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}] } elseif {[info exists S($option)]} { return $S($option) } return -code error -errorcode [list TK LOOKUP OPTION $option] \ "bad option \"$option\": must be\ -command, -font, -parent, -title or -visible" } set cache [dict create -parent $S(-parent) -title $S(-title) \ -font $S(-font) -command $S(-command)] set r [tclParseConfigSpec [namespace which -variable S] $specs "" $args] if {![winfo exists $S(-parent)]} { set code [list TK LOOKUP WINDOW $S(-parent)] set err "bad window path name \"$S(-parent)\"" array set S $cache return -code error -errorcode $code $err } if {[string trim $S(-title)] eq ""} { set S(-title) [::msgcat::mc "Font"] } if {[winfo exists $S(W)] && [lsearch $args -font] != -1} { Init $S(-font) event generate $S(-parent) <> } return $r } proc ::tk::fontchooser::Create {} { variable S # Now build the dialog if {![winfo exists $S(W)]} { toplevel $S(W) -class TkFontDialog if {[package provide tcltest] ne {}} {set ::tk_dialog $S(W)} wm withdraw $S(W) wm title $S(W) $S(-title) wm transient $S(W) [winfo toplevel $S(-parent)] set scaling [tk scaling] set sizeWidth [expr {int([string length [::msgcat::mc "&Size:"]] * $scaling)}] set outer [::ttk::frame $S(W).outer -padding {10 10}] ::tk::AmpWidget ::ttk::label $S(W).font -text [::msgcat::mc "&Font:"] ::tk::AmpWidget ::ttk::label $S(W).style -text [::msgcat::mc "Font st&yle:"] ::tk::AmpWidget ::ttk::label $S(W).size -text [::msgcat::mc "&Size:"] -width $sizeWidth ttk::entry $S(W).efont -width 18 \ -textvariable [namespace which -variable S](font) ttk::entry $S(W).estyle -width 10 \ -textvariable [namespace which -variable S](style) ttk::entry $S(W).esize -textvariable [namespace which -variable S](size) \ -width 3 -validate key -validatecommand {string is double %P} ttk_slistbox $S(W).lfonts -height 7 -exportselection 0 \ -selectmode browse -activestyle none \ -listvariable [namespace which -variable S](fonts) ttk_slistbox $S(W).lstyles -width 5 -height 7 -exportselection 0 \ -selectmode browse -activestyle none \ -listvariable [namespace which -variable S](styles) ttk_slistbox $S(W).lsizes -width 4 -height 7 -exportselection 0 \ -selectmode browse -activestyle none \ -listvariable [namespace which -variable S](sizes) set WE $S(W).effects ::ttk::labelframe $WE -text [::msgcat::mc "Effects"] ::tk::AmpWidget ::ttk::checkbutton $WE.strike \ -variable [namespace which -variable S](strike) \ -text [::msgcat::mc "Stri&keout"] \ -command [namespace code [list Click strike]] ::tk::AmpWidget ::ttk::checkbutton $WE.under \ -variable [namespace which -variable S](under) \ -text [::msgcat::mc "&Underline"] \ -command [namespace code [list Click under]] set bbox [::ttk::frame $S(W).bbox] ::ttk::button $S(W).ok -text [::msgcat::mc OK] -default active\ -command [namespace code [list Done 1]] ::ttk::button $S(W).cancel -text [::msgcat::mc Cancel] \ -command [namespace code [list Done 0]] ::tk::AmpWidget ::ttk::button $S(W).apply -text [::msgcat::mc "&Apply"] \ -command [namespace code [list Apply]] wm protocol $S(W) WM_DELETE_WINDOW [namespace code [list Done 0]] # Calculate minimum sizes ttk::scrollbar $S(W).tmpvs set scroll_width [winfo reqwidth $S(W).tmpvs] destroy $S(W).tmpvs set minsize(gap) 10 set minsize(bbox) [winfo reqwidth $S(W).ok] set minsize(fonts) \ [expr {[font measure TkDefaultFont "Helvetica"] + $scroll_width}] set minsize(styles) \ [expr {[font measure TkDefaultFont "Bold Italic"] + $scroll_width}] set minsize(sizes) \ [expr {[font measure TkDefaultFont "-99"] + $scroll_width}] set min [expr {$minsize(gap) * 4}] foreach {what width} [array get minsize] { incr min $width } wm minsize $S(W) $min 260 bind $S(W) [namespace code [list Done 1]] bind $S(W) [namespace code [list Done 0]] bind $S(W) [namespace code [list Visibility %W 1]] bind $S(W) [namespace code [list Visibility %W 0]] bind $S(W) [namespace code [list Visibility %W 0]] bind $S(W).lfonts.list <> [namespace code [list Click font]] bind $S(W).lstyles.list <> [namespace code [list Click style]] bind $S(W).lsizes.list <> [namespace code [list Click size]] bind $S(W) [list ::tk::AltKeyInDialog $S(W) %A] bind $S(W).font <> [list ::focus $S(W).efont] bind $S(W).style <> [list ::focus $S(W).estyle] bind $S(W).size <> [list ::focus $S(W).esize] bind $S(W).apply <> [namespace code [list Apply]] bind $WE.strike <> [list $WE.strike invoke] bind $WE.under <> [list $WE.under invoke] set WS $S(W).sample ::ttk::labelframe $WS -text [::msgcat::mc "Sample"] ::ttk::label $WS.sample -relief sunken -anchor center \ -textvariable [namespace which -variable S](sampletext) set S(sample) $WS.sample grid $WS.sample -sticky news -padx 6 -pady 4 grid rowconfigure $WS 0 -weight 1 grid columnconfigure $WS 0 -weight 1 grid propagate $WS 0 grid $S(W).ok -in $bbox -sticky new -pady {0 2} grid $S(W).cancel -in $bbox -sticky new -pady 2 if {$S(-command) ne ""} { grid $S(W).apply -in $bbox -sticky new -pady 2 } grid columnconfigure $bbox 0 -weight 1 grid $WE.strike -sticky w -padx 10 grid $WE.under -sticky w -padx 10 -pady {0 30} grid columnconfigure $WE 1 -weight 1 grid $S(W).font x $S(W).style x $S(W).size x -in $outer -sticky w grid $S(W).efont x $S(W).estyle x $S(W).esize x $bbox -in $outer -sticky ew grid $S(W).lfonts x $S(W).lstyles x $S(W).lsizes x ^ -in $outer -sticky news grid $WE x $WS - - x ^ -in $outer -sticky news -pady {15 30} grid configure $bbox -sticky n grid columnconfigure $outer {1 3 5} -minsize $minsize(gap) grid columnconfigure $outer {0 2 4} -weight 1 grid columnconfigure $outer 0 -minsize $minsize(fonts) grid columnconfigure $outer 2 -minsize $minsize(styles) grid columnconfigure $outer 4 -minsize $minsize(sizes) grid columnconfigure $outer 6 -minsize $minsize(bbox) grid $outer -sticky news grid rowconfigure $S(W) 0 -weight 1 grid columnconfigure $S(W) 0 -weight 1 Init $S(-font) trace add variable [namespace which -variable S](size) \ write [namespace code [list Tracer]] trace add variable [namespace which -variable S](style) \ write [namespace code [list Tracer]] trace add variable [namespace which -variable S](font) \ write [namespace code [list Tracer]] } else { Init $S(-font) } return } # ::tk::fontchooser::Done -- # # Handles teardown of the dialog, calling -command if needed # # Arguments: # ok true if user pressed OK # proc ::tk::::fontchooser::Done {ok} { variable S if {! $ok} { set S(result) "" } trace vdelete S(size) w [namespace code [list Tracer]] trace vdelete S(style) w [namespace code [list Tracer]] trace vdelete S(font) w [namespace code [list Tracer]] destroy $S(W) if {$ok && $S(-command) ne ""} { uplevel #0 $S(-command) [list $S(result)] } } # ::tk::fontchooser::Apply -- # # Call the -command procedure appending the current font # Errors are reported via the background error mechanism # proc ::tk::fontchooser::Apply {} { variable S if {$S(-command) ne ""} { if {[catch {uplevel #0 $S(-command) [list $S(result)]} err]} { ::bgerror $err } } event generate $S(-parent) <> } # ::tk::fontchooser::Init -- # # Initializes dialog to a default font # # Arguments: # defaultFont font to use as the default # proc ::tk::fontchooser::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) [::msgcat::mc "Bold Italic"] } elseif {$F(-weight) eq "bold"} { set S(style) [::msgcat::mc "Bold"] } elseif {$F(-slant) eq "italic"} { set S(style) [::msgcat::mc "Italic"] } set S(first) 0 } Tracer a b c Update } # ::tk::fontchooser::Click -- # # Handles all button clicks, updating the appropriate widgets # # Arguments: # who which widget got pressed # proc ::tk::fontchooser::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]] } Update } # ::tk::fontchooser::Tracer -- # # Handles traces on key variables, updating the appropriate widgets # # Arguments: # standard trace arguments (not used) # proc ::tk::fontchooser::Tracer {var1 var2 op} { variable S set bad 0 set nstate normal # Make selection in each listbox foreach var {font style size} { set value [string tolower $S($var)] $S(W).l${var}s selection clear 0 end set n [lsearch -exact $S(${var}s,lcase) $value] $S(W).l${var}s selection set $n if {$n != -1} { set S($var) [lindex $S(${var}s) $n] $S(W).e$var icursor end $S(W).e$var selection clear } else { ;# No match, try prefix # Size is weird: valid numbers are legal but don't display # unless in the font size list set n [lsearch -glob $S(${var}s,lcase) "$value*"] set bad 1 if {$var ne "size" || ! [string is double -strict $value]} { set nstate disabled } } $S(W).l${var}s see $n } if {!$bad} { Update } $S(W).ok configure -state $nstate $S(W).apply configure -state $nstate } # ::tk::fontchooser::Update -- # # Shows a sample of the currently selected font # proc ::tk::fontchooser::Update {} { variable S set S(result) [list $S(font) $S(size)] if {$S(style) eq [::msgcat::mc "Bold"]} {lappend S(result) bold} if {$S(style) eq [::msgcat::mc "Italic"]} {lappend S(result) italic} if {$S(style) eq [::msgcat::mc "Bold Italic"]} {lappend S(result) bold italic} if {$S(strike)} {lappend S(result) overstrike} if {$S(under)} {lappend S(result) underline} $S(sample) configure -font $S(result) } # ::tk::fontchooser::Visibility -- # # Notify the parent when the dialog visibility changes # proc ::tk::fontchooser::Visibility {w visible} { variable S if {$w eq $S(W)} { event generate $S(-parent) <> } } # ::tk::fontchooser::ttk_listbox -- # # Create a properly themed scrolled listbox. # This is exactly right on XP but may need adjusting on other platforms. # proc ::tk::fontchooser::ttk_slistbox {w args} { set f [ttk::frame $w -style FontchooserFrame -padding 2] if {[catch { listbox $f.list -relief flat -highlightthickness 0 -borderwidth 0 {*}$args ttk::scrollbar $f.vs -command [list $f.list yview] $f.list configure -yscrollcommand [list $f.vs set] grid $f.list $f.vs -sticky news grid rowconfigure $f 0 -weight 1 grid columnconfigure $f 0 -weight 1 interp hide {} $w interp alias {} $w {} $f.list } err opt]} { destroy $f return -options $opt $err } return $w } ====== <> Command | Widget