Scid  4.6.5
font.tcl
Go to the documentation of this file.
1 ########################################
2 ### utils/font.tcl: part of Scid.
3 #
4 # The following procs implement a font selection dialog. I found the code
5 # at codearchive.com (I don't think there was an author listed for it) and
6 # simplified it for use with Scid.
7 
8 # FontDialog:
9 # Creates a font dialog to select a font.
10 # Returns 1 if user chose a font, 0 otherwise.
11 #
12 proc FontDialog {font_name {options ""} {fixedOnly 0}} {
13  global fd_family fd_style fd_size fd_close
14  global fd_strikeout fd_underline
15 
16  set fd_family {}; set fd_style {}; set fd_size {}
17  set fd_close -1
18 
19  set unsorted_fam [font families]
20  set families [lsort $unsorted_fam]
21  if {$fixedOnly} {
22  set fams $families
23  set families {}
24  foreach f $fams {
25  if {[font metrics [list $f] -fixed] == 1} { lappend families $f}
26  }
27  }
28 
29  # Get current font's family and so on.
30  if {[llength $options] == 4} {
31  # Use provided font settings:
32  set family [lindex $options 0]
33  set size [lindex $options 1]
34  set weight [lindex $options 2]
35  set slant [lindex $options 3]
36  } else {
37  # Get options using [font actual]:
38  set family [font actual $font_name -family]
39  set size [font actual $font_name -size]
40  set weight [font actual $font_name -weight]
41  set slant [font actual $font_name -slant]
42  }
43 
44  # Default style.
45  set fd_style "Regular"
46  if { $slant == "italic" } {
47  if { $weight == "bold" } {
48  set fd_style "Bold Italic"
49  } else {
50  set fd_style "Italic"
51  }
52  } else {
53  if { $weight == "bold" } {
54  set fd_style "Bold"
55  }
56  }
57 
58  set fd_family $family
59  set fd_size $size
60 
61  # Create font dialog.
62  set tl .fontdialog
63  toplevel $tl
64  set dlg $tl.f
65  pack [ttk::frame $tl.f] -expand 1 -fill both
66  wm protocol $tl WM_DELETE_WINDOW "set fd_close 0"
67  wm title $tl Font
68 
69  ttk::label $dlg.family_lbl -text "Font:" -anchor w
70  ttk::entry $dlg.family_ent -textvariable fd_family -background white
71  bind $dlg.family_ent <Key-Return> "FontDialogRegen $font_name"
72  grid config $dlg.family_lbl -column 0 -row 0 -sticky w
73  grid config $dlg.family_ent -column 0 -row 1 -sticky snew
74 
75  ttk::label $dlg.style_lbl -text "Font Style:" -anchor w
76  ttk::entry $dlg.style_ent -textvariable fd_style -width 11 -background white
77  bind $dlg.style_ent <Key-Return> "FontDialogRegen $font_name"
78  grid config $dlg.style_lbl -column 1 -row 0 -sticky w
79  grid config $dlg.style_ent -column 1 -row 1 -sticky snew
80 
81  ttk::label $dlg.size_lbl -text "Size:" -anchor w
82  ttk::entry $dlg.size_ent -textvariable fd_size -width 4 -background white
83  bind $dlg.size_ent <Key-Return> "FontDialogRegen $font_name"
84  grid config $dlg.size_lbl -column 2 -row 0 -sticky w
85  grid config $dlg.size_ent -column 2 -row 1 -sticky snew
86 
87  # Font family listbox.
88  set fr $dlg.family_list
89  ttk::frame $fr
90  listbox $fr.list -height 6 -selectmode single -width 30 -background white -yscrollcommand "$fr.scroll set"
91  ttk::scrollbar $fr.scroll -command "$fr.list yview"
92 
93  foreach f $families {
94  $fr.list insert end $f
95  }
96 
97  bind $fr.list <Double-Button-1> "FontDialogFamily $fr.list $font_name $dlg.family_ent"
98 
99  pack $fr.scroll -side right -fill y
100  pack $fr.list -side left
101  grid config $fr -column 0 -row 2 -rowspan 16
102 
103  # Font style listbox.
104  set fr $dlg.style_list
105  ttk::frame $fr
106  listbox $fr.list -height 6 -selectmode single -width 11 -background white -yscrollcommand "$fr.scroll set"
107  ttk::scrollbar $fr.scroll -command "$fr.list yview"
108 
109  $fr.list insert end "Regular"
110  $fr.list insert end "Bold"
111  $fr.list insert end "Italic"
112  $fr.list insert end "Bold Italic"
113 
114  bind $fr.list <Double-Button-1> "FontDialogStyle $fr.list $font_name $dlg.style_ent"
115 
116  pack $fr.scroll -side right -fill y
117  pack $fr.list -side left
118  grid config $fr -column 1 -row 2 -rowspan 16
119 
120  # Font size listbox.
121  set fr $dlg.size_list
122  ttk::frame $fr
123  listbox $fr.list -height 6 -selectmode single -width 4 -background white -yscrollcommand "$fr.scroll set"
124  ttk::scrollbar $fr.scroll -command "$fr.list yview"
125 
126  for {set i 7} {$i <= 20} {incr i} {
127  $fr.list insert end $i
128  }
129 
130  bind $fr.list <Double-Button-1> "FontDialogSize $fr.list $font_name $dlg.size_ent"
131 
132  pack $fr.scroll -side right -fill y
133  pack $fr.list -side left
134  grid config $fr -column 2 -row 2 -rowspan 16
135 
136  # OK/Cancel
137  set fr $dlg.ok_cancel
138  ttk::frame $fr
139 
140  ttk::button $fr.ok -text "OK" -command "set fd_close 1"
141  ttk::button $fr.cancel -text "Cancel" -command "set fd_close 0"
142  pack $fr.ok -side top -fill x
143  pack $fr.cancel -side top -fill x -pady 2
144  ttk::button $fr.help -text "Help" -command "helpWindow Options"
145  pack $fr.help -side top -fill x -pady 10
146  grid config $fr -column 4 -row 1 -rowspan 2 -sticky snew -padx 12
147 
148  # Sample text
149  set fr $dlg.sample
150  ttk::frame $fr -borderwidth 3 -relief groove
151  ttk::label $fr.l_sample -text "Sample" -anchor w
152 
153  ttk::label $fr.sample -font $font_name -relief sunken -text "This is some sample text\nAaBbCcDdEeFfGgHhIiJjKkLlMm\n 0123456789. +=-\n\u2654 \u2655 \u2656 \u2657 \u2658"
154 
155  pack $fr.l_sample -side top -fill x -pady 4
156  pack $fr.sample -side top -pady 4 -ipadx 10 -ipady 10
157 
158  grid config $fr -column 0 -columnspan 3 -row 20 -rowspan 2 -sticky snew -pady 10 -padx 2
159 
160  # Make this a modal dialog.
161  tkwait variable fd_close
162 
163  # Get rid of dialog and return value.
164  destroy $tl
165 
166  # Restore old font characteristics on a cancel:
167  if { $fd_close == 0 } {
168  font configure $font_name -family $family -size $size -slant $slant -weight $weight
169  return ""
170  }
171 
172  return [list $fd_family $fd_size [FontWeight $fd_style] [FontSlant $fd_style]]
173 }
174 
175 
176 proc FontDialogFamily { listname font_name entrywidget } {
177  # Get selected text from list.
178  catch {
179  set item_num [$listname curselection]
180  set item [$listname get $item_num]
181 
182  # Set selected list item into entry for font family.
183  $entrywidget delete 0 end
184  $entrywidget insert end $item
185 
186  # Use this family in the font and regenerate font.
187  FontDialogRegen $font_name
188  }
189 }
190 
191 
192 proc FontDialogStyle { listname font_name entrywidget } {
193  # Get selected text from list.
194  catch {
195  set item_num [$listname curselection]
196  set item [$listname get $item_num]
197 
198  # Set selected list item into entry for font family.
199  $entrywidget delete 0 end
200  $entrywidget insert end $item
201 
202  # Use this family in the font and regenerate font.
203  FontDialogRegen $font_name
204  }
205 }
206 
207 
208 proc FontDialogSize { listname font_name entrywidget } {
209  # Get selected text from list.
210  catch {
211  set item_num [$listname curselection]
212  set item [$listname get $item_num]
213 
214  # Set selected list item into entry for font family.
215  $entrywidget delete 0 end
216  $entrywidget insert end $item
217 
218  # Use this family in the font and regenerate font.
219  FontDialogRegen $font_name
220  }
221 }
222 
223 proc FontWeight {style} {
224  if { $style == "Bold Italic" || $style == "Bold" } {
225  return "bold"
226  }
227  return "normal"
228 }
229 
230 proc FontSlant {style} {
231  if { $style == "Bold Italic" || $style == "Italic" } {
232  return "italic"
233  }
234  return "roman"
235 }
236 
237 # FontDialogRegen: Regenerates font from attributes.
238 proc FontDialogRegen { font_name } {
239  global fd_family fd_style fd_size
240 
241  set weight "normal"
242  if { $fd_style == "Bold Italic" || $fd_style == "Bold" } {
243  set weight "bold"
244  }
245 
246  set slant "roman"
247  if { $fd_style == "Bold Italic" || $fd_style == "Italic" } {
248  set slant "italic"
249  }
250 
251  # Change font to have new characteristics.
252  font configure $font_name -family $fd_family -size $fd_size -slant $slant -weight $weight
253 }
254 
255 ## End of file: fontsel.tcl