From 334633beef875162712334b869ff6f1d91bb1128 Mon Sep 17 00:00:00 2001
From: patthoyts <patthoyts@users.sourceforge.net>
Date: Fri, 12 Dec 2008 02:02:35 +0000
Subject: Added a simple fontchooser demo to the common dialogs section.

---
 ChangeLog                    | 17 +++++++----
 library/demos/fontchoose.tcl | 71 ++++++++++++++++++++++++++++++++++++++++++++
 library/demos/widget         |  3 +-
 3 files changed, 84 insertions(+), 7 deletions(-)
 create mode 100644 library/demos/fontchoose.tcl

diff --git a/ChangeLog b/ChangeLog
index 9792ac5..418b439 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,15 +1,20 @@
+2008-12-12  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* library/demos/fontchoose.tcl: Simple fontchooser demo
+	* library/demos/widget:
+
 2008-12-11  Jan Nijtmans  <nijtmans@users.sf.net>
-    * generic/tk3d.c:    Make error message from Tk_GetRelief the
-                         same as for Tk_GetReliefFromObj
-    * tests/canvas.test  Adapt test cases for changed error message
-    * tests/scrollbar.test
-    * tests/textTag.test
+	* generic/tk3d.c:    Make error message from Tk_GetRelief the
+	                     same as for Tk_GetReliefFromObj
+	* tests/canvas.test  Adapt test cases for changed error message
+	* tests/scrollbar.test
+	* tests/textTag.test
 
 2008-12-11  Joe English  <jenglish@users.sourceforge.net>
 
 	* library/demos/*.tcl: Omit contraindicated [package require Ttk].
 	Remove logic that switches [ttk::scrollbar]s to [tk::scrollbar]s
-	based on [tk windowingsystem]; this is already handled in 
+	based on [tk windowingsystem]; this is already handled in
 	library/ttk/scrollbar.tcl.
 
 2008-12-10  Daniel Steffen  <das@users.sourceforge.net>
diff --git a/library/demos/fontchoose.tcl b/library/demos/fontchoose.tcl
new file mode 100644
index 0000000..3410d12
--- /dev/null
+++ b/library/demos/fontchoose.tcl
@@ -0,0 +1,71 @@
+# fontchoose.tcl --
+#
+# Show off the stock font selector dialog
+#
+# RCS: @(#) $Id: fontchoose.tcl,v 1.1 2008/12/12 02:02:35 patthoyts Exp $
+
+if {![info exists widgetDemo]} {
+    error "This script should be run from the \"widget\" demo."
+}
+
+package require Tk
+
+set w .fontchoice
+catch {destroy $w}
+toplevel $w
+wm title $w "Font Selection Dialog"
+wm iconname $w "fontchooser"
+positionWindow $w
+
+catch {font create FontchooseDemoFont {*}[font actual TkDefaultFont]}
+
+# The font chooser needs to be configured and then shown.
+proc SelectFont {parent} {
+    tk fontchooser configure -font FontchooseDemoFont \
+        -command ApplyFont -parent $parent
+    tk fontchooser show
+}
+
+proc ApplyFont {font} {
+    font configure FontchooseDemoFont {*}[font actual $font]
+}
+
+# When the visibility of the fontchooser changes, the following event is fired
+# to the parent widget.
+#
+bind $w <<TkFontchooserVisibility>> {
+    if {[tk fontchooser configure -visible]} {
+        %W.f.font state disabled
+    } else {
+        %W.f.font state !disabled
+    }
+}
+
+
+set f [ttk::frame $w.f -relief sunken -padding 2]
+
+text $f.msg -font FontchooseDemoFont -width 40 -height 6 -borderwidth 0 \
+    -yscrollcommand [list $f.vs set]
+ttk::scrollbar $f.vs -command [list $f.msg yview]
+
+$f.msg insert end "Press the buttons below to choose a new font for the\
+  text shown in this window.\n" {}
+
+ttk::button $f.font -text "Set font ..." -command [list SelectFont $w]
+
+grid $f.msg $f.vs -sticky news
+grid $f.font -    -sticky e
+grid columnconfigure $f 0 -weight 1
+grid rowconfigure $f 0 -weight 1
+bind $w <Visibility> {
+    bind %W <Visibility> {}
+    grid propagate %W.f 0    
+}
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+
+grid $f -sticky news
+grid $btns -sticky ew
+grid columnconfigure $w 0 -weight 1
+grid rowconfigure $w 0 -weight 1
diff --git a/library/demos/widget b/library/demos/widget
index e9e2d51..5c4f722 100644
--- a/library/demos/widget
+++ b/library/demos/widget
@@ -10,7 +10,7 @@ exec wish "$0" "$@"
 # separate ".tcl" files is this directory, which are sourced by this script as
 # needed.
 #
-# RCS: @(#) $Id: widget,v 1.52 2008/12/11 18:13:08 jenglish Exp $
+# RCS: @(#) $Id: widget,v 1.53 2008/12/12 02:02:35 patthoyts Exp $
 
 package require Tcl	8.5
 package require Tk	8.5
@@ -386,6 +386,7 @@ addFormattedText {
     @@demo msgbox	Message boxes
     @@demo filebox	File selection dialog
     @@demo clrpick	Color picker
+    @@demo fontchoose	Font selection dialog
 
     @@subtitle	Animation
     @@new
-- 
cgit v0.12