summaryrefslogtreecommitdiffstats
path: root/library
diff options
context:
space:
mode:
Diffstat (limited to 'library')
-rw-r--r--library/demos/fontchoose.tcl71
-rw-r--r--library/demos/widget3
2 files changed, 73 insertions, 1 deletions
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