home *** CD-ROM | disk | FTP | other *** search
/ Practical Programming in Tcl & Tk (4th Edition) / TCLBOOK4.BIN / pc / exsource.old / 40_4.tcl < prev    next >
Text File  |  2003-04-15  |  4KB  |  177 lines
  1. #
  2. # Example 40-4
  3. # Font selection dialog.
  4. #
  5.  
  6. proc Font_Select {{top .fontsel}} {
  7.     global font
  8.  
  9.     # Create File, Font, Size, and Format menus
  10.  
  11.     toplevel $top -class Fontsel -bd 10
  12.     set menubar [menu $top.menubar]
  13.     $top config -menu $menubar
  14.     foreach x {File Font Size Format} {
  15.         set menu [menu $menubar.[string tolower $x]]
  16.         $menubar add cascade -menu $menu -label $x
  17.     }
  18.     $menubar.file add command -label Reset -command FontReset
  19.     $menubar.file add command -label OK \
  20.         -command {set font(ok) ok}
  21.     $menubar.file add command -label Cancel \
  22.         -command {set font(ok) cancel}
  23.  
  24.     # The Fonts menu lists the available Font families.
  25.  
  26.     set allfonts [font families]
  27.     set numfonts [llength $allfonts]
  28.     set limit 20
  29.     if {$numfonts < $limit} {
  30.  
  31.         # Display the fonts in a single menu
  32.  
  33.         foreach family $allfonts {
  34.             $menubar.font add radio -label $family \
  35.                 -variable font(-family) \
  36.                 -value $family \
  37.                 -command FontUpdate
  38.         }
  39.     } else {
  40.  
  41.         # Too many fonts. Create a set of cascaded menus to 
  42.         # display all the font possibilities
  43.  
  44.         set c 0 ; set l 0
  45.         foreach family $allfonts {
  46.             if {$l == 0} {
  47.                 $menubar.font add cascade -label $family... \
  48.                     -menu $menubar.font.$c
  49.                 set m [menu $menubar.font.$c]
  50.                 incr c
  51.             }
  52.             $m add radio -label $family \
  53.                 -variable font(-family) \
  54.                 -value $family \
  55.                 -command FontUpdate
  56.             set l [expr ($l +1) % $limit]
  57.         }
  58.     }
  59.  
  60.     # Complete the other menus
  61.  
  62.     foreach size {7 8 10 12 14 18 24 36 72} {
  63.         $menubar.size add radio -label $size \
  64.             -variable font(-size) \
  65.             -value $size \
  66.             -command FontUpdate
  67.     }
  68.     $menubar.size add command -label Other... \
  69.             -command [list FontSetSize $top]
  70.     $menubar.format add check -label Bold \
  71.             -variable font(-weight) \
  72.             -onvalue bold -offvalue normal \
  73.             -command FontUpdate
  74.     $menubar.format add check -label Italic \
  75.             -variable font(-slant) \
  76.             -onvalue italic -offvalue roman \
  77.             -command FontUpdate
  78.     $menubar.format add check -label underline \
  79.         -variable font(-underline) \
  80.         -command FontUpdate
  81.     $menubar.format add check -label overstrike \
  82.         -variable font(-overstrike) \
  83.         -command FontUpdate
  84.  
  85.     # FontReset initializes the font array, which causes
  86.     # the radio menu entries to get highlighted.
  87.  
  88.     FontReset
  89.  
  90.     # This label displays the current font
  91.  
  92.     label $top.font -textvar font(name) -bd 5
  93.     # This message displays a sampler of the font.
  94.  
  95.     message $top.msg -aspect 1000 \
  96.                     -borderwidth 10 -font fontsel \
  97.                     -text "
  98. ABCDEFGHIJKLMNOPQRSTUVWXYZ
  99. abcdefghijklmnopqrstuvwxyz
  100. 0123456789
  101. !@#$%^&*()_+-=[]{};:\"'` ~,.<>/?\\|
  102. "
  103.  
  104.     # Lay out the dialog
  105.  
  106.     pack $top.font $top.msg -side top
  107.     set f [frame $top.buttons]
  108.     button $f.ok -text Ok -command {set font(ok) 1}
  109.     button $f.cancel -text Cancel -command {set font(ok) 0}
  110.     pack $f.ok $f.cancel -padx 10 -side left
  111.     pack $f -side top
  112.  
  113.     # Dialog_Wait is defined in Example 37-1 on page 572
  114.  
  115.     set font(ok) cancel
  116.     Dialog_Wait $top font(ok)
  117.     destroy $top
  118.     if {$font(ok) == "ok"} {
  119.         return [array get font -*]
  120.     } else {
  121.         return {}
  122.     }
  123. }
  124.  
  125. # FontReset recreates a default font
  126.  
  127. proc FontReset {} {
  128.     catch {font delete fontsel}
  129.     font create fontsel
  130.     FontSet
  131. }
  132.  
  133. # FontSet initializes the font array with the settings
  134. # returned by the font actual command
  135.  
  136. proc FontSet {} {
  137.     global font
  138.  
  139.     # The name is the font configuration information
  140.     # with a line break so it looks nicer
  141.  
  142.     set font(name) [font actual fontsel]
  143.     regsub -- "-slant" $font(name) "\n-slant" font(name)
  144.  
  145.     # Save the actual parameters after any font substitutions
  146.  
  147.     array set font [font actual fontsel]
  148. }
  149.  
  150. # FontSetSize adds an entry widget to the dialog so you
  151. # can enter a specific font size.
  152.  
  153. proc FontSetSize {top} {
  154.     set f [frame $top.size -borderwidth 10]
  155.     pack $f -side top -fill x
  156.     label $f.msg -text "Size:"
  157.     entry $f.entry -textvariable font(-size)
  158.     bind $f.entry <Return> FontUpdate
  159.     pack $f.msg -side left
  160.     pack $f.entry -side top -fill x
  161. }
  162.  
  163. # FontUpdate is called when any of the font settings
  164. # are changed, either from the menu or FontSetSize
  165.  
  166. proc FontUpdate { } {
  167.     global font
  168.  
  169.     # The elements of font that have a leading - are
  170.     # used directly in the font configuration command.
  171.  
  172.     eval {font configure fontsel} [array get font -*]
  173.     FontSet
  174. }
  175.  
  176.  
  177.