Font chooser / font selection dialog

Although there are many similar font selection dialogs available,
I always wanted to create a dialog which allows to choose a font in an easy and efficient way.

This is a support package for tcl/tk which implements another kind of font selection dialog (or so called font chooser dialog).

Graphical User Interface

The new dialog is based on tablelist and looks like:

Features

  • live preview of the font style
  • possibility to filter names, so that a huge list of available fonts can be filtered down easily
  • a column which indicates fixed fonts
  • search with highlight capability

Note:

Some one might miss a possibility to change the font size. Nowadays modern applications support a zoom-up / zoom-down functionality directly in the main GUI window as this is more user-friendly rather than hiding this option within a dialog down the line.

Installation

The package is meant to be a utility package for the more adventurous tcl/tk programmer. I use this dialog quite often in various applications, it is easy to implement and fun to use.

The package requires tablelist 6.1 or newer. Thanks to Csaba Nemethi for the creation and continuous development of tablelist.

During package development, I usually prepare a test file used to run the code. Within this file, all package requirements are addressed, so when going through this file it becomes quite clear how to use the package.

Source-code of fontseldialog_test.tcl...

# ------------------------------------------------------------------------
# fontseldialog_test.tcl ---
# ------------------------------------------------------------------------
# (c) 2016, Johann Oberdorfer - Engineering Support | CAD | Software
#     johann.oberdorfer [at] gmail.com
#     www.johann-oberdorfer.eu
# ------------------------------------------------------------------------
# This source file is distributed under the BSD license.
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#   See the BSD License for more details.
# ------------------------------------------------------------------------
# Purpose:
#  This file belongs to the fontseldialog.tcl widget
# ------------------------------------------------------------------------

set dir [file dirname [info script]]

set auto_path [linsert $auto_path 0 [file join $dir "."]]
set auto_path [linsert $auto_path 0 [file join $dir ".."]]
set auto_path [linsert $auto_path 0 [file join $dir "../../lib"]]


# test-run ...

package require Tk
package require tile

package require -exact tablelist_tile 6.1
package require fontseldialog 0.1


wm withdraw .

set showconsole 0
if { $showconsole && $::tcl_platform(platform) == "windows"} {
	console show
	console eval {wm protocol . WM_DELETE_WINDOW {exit 0}}
}

set rval [fontseldialog::fontseldialog \
			-parent "" \
			-title  "Select Font Style:" \
			-font   "Comic Sans MS" \
		]

puts "Selection return value is: \"$rval\""

Sourcecode of fontseldialog.tcl...

# ------------------------------------------------------------------------
# fontseldialog.tcl ---
# ------------------------------------------------------------------------
# (c) 2017, Johann Oberdorfer - Engineering Support | CAD | Software
#     johann.oberdorfer [at] gmail.com
#     www.johann-oberdorfer.eu
# ------------------------------------------------------------------------
# This source file is distributed under the BSD license.
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#   See the BSD License for more details.
# ------------------------------------------------------------------------
# Purpose:
#   Create a tableview and show the available font styles
#   in 2 columss name / fixed font / formatted_text...
# ------------------------------------------------------------------------

# ... auf der Suche nach einer vollendeten Einheit
#     von Material, Form und Funktion ...
#

# package require Tk
# package require -exact tablelist_tile 6.1

package provide fontseldialog 0.1


namespace eval fontseldialog {

	variable widgetDefaults
	variable widgetImages
	variable widgetVars

	array set widgetDefaults {
		wparent ""
		title "Font Selection Dialog"
		font ""
	}

	# initializing required images...
	set this_dir   [file dirname [info script]]
	set image_dir  [file join $this_dir "images"]
	set image_file [file join $this_dir "ImageLib.tcl"]

	proc LoadImages {image_dir {patterns {*.gif}}} {
		foreach p $patterns {
			foreach file [glob -nocomplain -directory $image_dir $p] {
				set img [file tail [file rootname $file]]
				if { ![info exists images($img)] } {
					set images($img) [image create photo -file $file]
				}
			}}
		return [array get images]
	}

	if { [file exists $image_file] } {
		source $image_file
		array set widgetImages [array get images]
	} else {
		array set widgetImages [LoadImages \
				[file join $image_dir] {"*.gif" "*.png"}]
	}

	proc GetFontInformation {} {
		variable widgetDefaults
		variable widgetVars

		# make shure to create fonts + data list only once
		if {[info exists widgetVars(font_info)] &&
			[llength $widgetVars(font_info)] > 0} {
			
			return $widgetVars(font_info)
		}

		set widgetVars(font_info) [list]
	
		foreach font [lsort -dictionary [font families]] {
		
			# top and bottom spacing for this font is very big,
			# so let's filter out this specific font:
			if {$font == "Cambria Math"} { continue }
			
			set fid [font create -family $font]
			
			set fmetrics ""
			if {[font metrics $fid -fixed]} {
				set fmetrics "*"
			}
		
			lappend widgetVars(font_info) \
				[list [string trim $font] $fmetrics $widgetDefaults(sampletxt) $fid]
		}

		return $widgetVars(font_info)
	}

	proc ShowFont {fname fid} {
		variable widgetVars
		wm title $widgetVars(this) "Font selection dialog - $fname"
		# $widgetVars(wlabel) configure -font $fid
	}
	
	proc CancelCmd {} {
		variable widgetVars
		set widgetVars(is_ok) 2
	}
	
	proc OKButtonCmd {} {
		variable widgetVars
		set widgetVars(is_ok) 1
	}
	
	proc EnableOkButtonCmd {} {
		variable widgetVars		
		$widgetVars(ok_button) configure -state normal
	}

	proc DisableOkButtonCmd {} {
		variable widgetVars
		$widgetVars(ok_button) configure -state disabled
	}
	
		
	proc EntryBindingsCmd {tbl {mode "default"}} {
		variable widgetDefaults
		variable widgetVars
		
		switch -- $mode {
			"default" {
				set widgetVars(combobox_var) ""
				set searchtxt [string trim $widgetVars(entry_var)]				
				# if {$searchtxt == "" } { return }
			}
			"refresh" {
				# force refresh
				set widgetVars(entry_var) ""
				set widgetVars(combobox_var) ""
				set searchtxt ""
			}
			"combo" {
				set widgetVars(entry_var) ""
				set searchtxt [string trim $widgetVars(combobox_var)]
			}
			default {
				return -code error \
					"programmer's error: unknown $mode in proc EntryBindingsCmd"
			}
		}

		$tbl selection clear 0 end
		$tbl delete 0 end

		set idx 0
		foreach item [GetFontInformation] {
			set font [lindex $item 0]
			set fid [lindex $item end]

			if { $searchtxt == "" || \
				 [string first $searchtxt $font] != -1} {
			
				$tbl insert end $item
				$tbl cellconfigure "$idx,2" -font $fid
				incr idx
			}
		}
		
		$widgetVars(wstatus_label) configure -text \
			"There are $idx fonts available."

		DisableOkButtonCmd
	}

	proc TextSearch {w string tag} {
		$w tag remove $tag 0.0 end
		if {$string == ""} {
			return
		}
		set cur 0.0
		while 1 {
			set cur [$w search -count length $string $cur end]
			if {$cur == ""} {
				break
			}
			$w tag add $tag $cur "$cur + $length char"
			set cur [$w index "$cur + $length char"]
		}
	}
	
	# recursive function
	proc WinfoGetAllTextWidgets {wparent wlist} {
		upvar $wlist widget_list 
	
		foreach w [winfo children $wparent] {
			if { [winfo class $w] == "Text" } {
				lappend widget_list $w
			}
			WinfoGetAllTextWidgets $w widget_list
		}
	}

	proc ColorizeCmd {tbl textWidget key row col tabIdx1 tabIdx2 inStripe selected} {
		variable widgetVars
		
		if {! [info exists widgetVars(entry_var)] ||
			  [winfo class $textWidget] != "Text" } {
			return
		}
		
		
		# -development-
		# set wtext_list [list]
		# WinfoGetAllTextWidgets $tbl wtext_list
		# puts "There are [llength $wtext_list] text widgets available."
		# foreach wtext $wtext_list { puts $wtext }
		
		set searchtxt [string trim $widgetVars(entry_var)]
		
		if {[string length $searchtxt] <= 1}  {
			return
		}
		
		# #ce5555 / White
		$textWidget tag configure search \
			-background LightYellow -foreground Black
		
		TextSearch $textWidget $searchtxt search
	}

	proc ComboBoxSelectedCmd {tbl w} {
		EntryBindingsCmd $tbl "combo"
	}

	# -------------------------------------------------------------------------
	# gui declaration
	# -------------------------------------------------------------------------
	
	proc fontseldialog {args} {
		variable widgetDefaults
		variable widgetImages
		variable widgetVars
		
		# "AaBbCcDdEeFfGgHhIi 1234567890 .,+-:*?!"
		# "The quick brown fox jumps over the lazy dog."
		# "entia non sunt multiplicanda praeter necessitatem"
		#  - (use) no more things than necessary"
		# If two things do the same job, simpler is better.

		array set widgetDefaults {
			sampletxt "Entia non sunt multiplicanda praeter necessitatem."
		}
	
		set ind 0
		while { $ind < [llength $args] } {
			switch -exact -- [lindex $args $ind] {
				"-parent" {
					incr ind
					set widgetDefaults(wparent) [lindex $args $ind]
					incr ind
				}
				"-title" {
					incr ind
					set widgetDefaults(title) [lindex $args $ind]
					incr ind
				}
				"-font" {
					incr ind
					set widgetDefaults(font) [lindex $args $ind]
					incr ind
				}
				default {
					puts "unknown option [lindex $args $ind]"
					return ""
				}
			}
		}
		
		set w $widgetDefaults(wparent).fontseldialog
		set widgetVars(this) $w
		catch {destroy $w}
		
		toplevel $w -class FontSelDialog
		wm title $w widgetDefaults(title)
		wm geometry $w "800x650+150+150"
		wm transient $w $widgetDefaults(wparent)
		bind $w <KeyPress-Escape> "[namespace current]::CancelCmd"
		
		set fmain [ttk::frame $w.main -relief groove]
		pack $fmain -side bottom -fill x
		
		ttk::button $fmain.chk \
				-text "Continue with selected font..." \
				-compound left \
				-image $widgetImages(dialog-ok) \
				-command "[namespace current]::OKButtonCmd" \
				-state disabled
		
		set widgetVars(ok_button) $fmain.chk
		
		ttk::button $fmain.cancel \
				-text "Cancel" \
				-image $widgetImages(dialog-close) \
				-compound left \
				-command "[namespace current]::CancelCmd" \
				
		pack $fmain.chk $fmain.cancel -side left -expand true -padx 4 -pady 4
		
		# --------------------------
		# font selection gui
		# --------------------------

		set f [ttk::frame $w.help -height 20]
		pack $f -side bottom -fill x
		
		set widgetVars(wlabelframe) $f
		
		set msg "Hint: You might want to use one of the \"UI\" font styles"
		append msg "\nwhich are easy to read and look good for user interfaces."
	
		ttk::label $f.lbl -text $msg
		pack $f.lbl -anchor center
		
		set widgetVars(wlabel) $f.lbl
		
		set f [ttk::frame $w.entry]
		pack $f -side top -fill x

		ttk::label $f.lcombo -text "Filter: "
		ttk::combobox $f.combo \
			-width 5 -state readonly \
			-values [list "" "ExtB" "FB" "MS" "MT" "Sans" "UI" "Hand" "Script" "Light"] \
			-textvariable "[namespace current]::widgetVars(combobox_var)"

		set widgetVars(wcombobox) $f.combo
			
		ttk::label $f.lbl \
			-image $widgetImages(dialog-search)
		
		ttk::entry $f.entry \
			-width 40 \
			-textvariable "[namespace current]::widgetVars(entry_var)"

		set widgetVars(wentry) $f.entry

		ttk::button $f.bttn \
				-compound left \
				-image $widgetImages(dialog-refresh) \
				-style Toolbutton

		set widgetVars(wentry_bttn) $f.bttn
				
		pack $f.lcombo $f.combo $f.lbl -side left -padx 5 -pady 5
		pack $f.entry -side left -padx 5 -pady 5 -fill x -expand true
		pack $f.bttn -side left -padx 2
		
		set tf $w.tf
		ttk::frame $tf
		set tbl $tf.tbl
		set vsb $tf.vsb
		
		tablelist::tablelist $tbl \
				-columns {
					0 "Font Name"	left
					0 "fixed" center
					0 "Sample text" left
					0 "Font ID" right } \
				-labelcommand tablelist::sortByColumn \
				-yscrollcommand [list $vsb set] -width 0 \
				-spacing 1 \
				-showseparators yes \
				-selectmode single \
				-font APP_FONT_STD_NORMAL \
				-stripebackground #E0E8F0 \
				-selectbackground #A9D0F5 \
				-stretch all \
				-spacing 2
				
		$tbl configure -colorizecommand "[namespace current]::ColorizeCmd"
		$tbl columnconfigure end -hide yes
				
		ttk::scrollbar $vsb -orient vertical -command [list $tbl yview]
		
		grid $tbl -row 0 -rowspan 2 -column 0 -sticky news
		grid $vsb -row 0 -rowspan 2 -column 1 -sticky ns
		
		grid rowconfigure    $tf 1 -weight 1
		grid columnconfigure $tf 0 -weight 1
		pack $tf -side top -expand yes -fill both


		set f [ttk::frame $w.status]
		pack $f -side top -fill x

		ttk::label $f.status
		# -image $widgetImages(dialog-search)
		
		set widgetVars(wstatus_label) $f.status

		pack $f.status -anchor center -padx 5 -pady 5
		
		bind [$tbl bodypath] <Motion> {+
			set t [winfo parent %W]
			set x [expr {%x + [winfo x %W]}]
			set y [expr {%y + [winfo y %W]}]
			
			# enable move-over effect,
			focus $t
			$t configure -activestyle frame
			$t activate "@$x,$y"
			
			::fontseldialog::ShowFont \
				[lindex [$t get "@$x,$y"] 0] \
				[lindex [$t get "@$x,$y"] end]
		}

		bind [$tbl bodypath] <Leave> {
			set t [winfo parent %W]
			$t configure -activestyle none
		}		
		
		bind [$tbl bodypath] <ButtonPress-2> {
			[winfo parent %W] configure -cursor "hand2"
		}
		bind [$tbl bodypath] <ButtonRelease-2> {
			[winfo parent %W] configure -cursor ""
		}
		
		bind [$tbl bodypath] <ButtonRelease-1> {
			set t [winfo parent %W]
			set x [expr {%x + [winfo x %W]}]
			set y [expr {%y + [winfo y %W]}]
		
			# if a tablelist has only a few entries, an "empty area"
			# is shown after the last row 
			# the following if clause ensures that a click in
			# this area simply has no effect
			set row [lindex [split [$t containingcell $x $y] ","] 0]
			if {$row == -1} {
				::fontseldialog::DisableOkButtonCmd
			} else {
				set cell [$t nearestcell $x $y]
				::fontseldialog::EnableOkButtonCmd
			}
		}

		bind [$tbl bodypath] <Double-ButtonPress-1> "[namespace current]::OKButtonCmd"
		
		bind $widgetVars(wentry) \
			<KeyRelease> "[namespace current]::EntryBindingsCmd $tbl"
		$widgetVars(wentry_bttn) configure \
			-command "[namespace current]::EntryBindingsCmd $tbl refresh"

		bind $widgetVars(wcombobox) <<ComboboxSelected>> \
			"[namespace current]::ComboBoxSelectedCmd $tbl %W"
	
		# ---------------------------
		# fill tablelist with content
		# ---------------------------

		set default [lindex [$tbl configure -font] 3]
		
		set idx 0
		foreach item [GetFontInformation] {
			set font [lindex $item 0]
			set fid [lindex $item end]
			
			$tbl insert end $item
			$tbl cellconfigure "$idx,2" -font $fid
			incr idx
		}
		
		$widgetVars(wstatus_label) configure -text \
			"There are $idx fonts available."

		# perform font name preselection (if any)
		# ---------------------------------------

		if { $widgetDefaults(font) != ""} {
		
			# try to find font name and calculate index
			set data [list]
			foreach litem [$tbl get 0 end] {
				lappend data [lindex $litem 0]
			}
			
			if { [set idx [lsearch $data $widgetDefaults(font)]] != -1 } {

				# bummer !
				$tbl selection set $idx
				$tbl see [expr {$idx -3}]
				EnableOkButtonCmd
			}
		}
		
		after 6000 "catch {pack forget $widgetVars(wlabelframe)};"

		# --------------------------
		# --------------------------
		
		# wait user
		grab $widgetVars(this)
		tkwait variable "[namespace current]::widgetVars(is_ok)"
		grab release $widgetVars(this)
		
		if { $widgetVars(is_ok) == 1 } {
			# read actual selection:
			set sel [$tbl curselection]
			set retval [string trim [lindex [$tbl get $sel] 0]]
		} else {
			set retval ""
		}

		# clean fonts before leaving the dialog (if that matters)...
		foreach item [GetFontInformation] {
			set fid [lindex $item end]
			
			set widgetVars(font_info) [list]
			catch {font delete $fid}
		}
		
		destroy $widgetVars(this)
		return $retval
	}
}

Download

The actual source code can be downloaded directly from here:

Name:Size / byte:
148562

The software is free as air, free to use and free to modify.