00001 ###################################################################### 00002 # Name: fontchooser.tcl 00003 # Author: Trevor Williams (trevorw@sgi.com) 00004 # Date: 01/07/2016 00005 # Brief: Provides a UI and associated functionality for choosing a 00006 # font. 00007 # Attributions: 00008 # This code mainly comes from the ChooseFont package created 00009 # by Keith Vetter (June 2006). 00010 ###################################################################### 00011 00012 namespace eval fontchooser { 00013 00014 variable default_font 00015 00016 array set data {} 00017 00018 # Set the current default font 00019 set default_font [[ttk::entry .___e] cget -font] 00020 destroy .___e 00021 00022 ###################################################################### 00023 # Creates and configures a fontchooser widget and returns the pathname. 00024 proc create {w args} { 00025 00026 variable data 00027 00028 array set opts { 00029 -default "" 00030 -mono "" 00031 -effects 0 00032 -sizes "" 00033 -styles "" 00034 -highlight "" 00035 } 00036 array set opts $args 00037 00038 # Initialize variables 00039 switch $opts(-mono) { 00040 0 { set data($w,fonts) [lsort [find_font_class variable]] } 00041 1 { set data($w,fonts) [lsort [find_font_class mono]] } 00042 default { set data($w,fonts) [lsort [font families]] } 00043 } 00044 set data($w,styles) [expr {($opts(-styles) eq "") ? {Regular Italic Bold "Bold Italic"} : $opts(-styles)}] 00045 set data($w,sizes) [expr {($opts(-sizes) eq "") ? {6 7 8 9 10 11 12 14 16 18 20 22 24 26 28} : $opts(-sizes)}] 00046 00047 set data($w,font) "" 00048 set data($w,style) "" 00049 set data($w,size) "" 00050 set data($w,strike) 0 00051 set data($w,under) 0 00052 00053 set data($w,fonts,lcase) [string tolower $data($w,fonts)] 00054 set data($w,styles,lcase) [string tolower $data($w,styles)] 00055 set data($w,sizes,lcase) $data($w,sizes) 00056 00057 ttk::frame $w 00058 ttk::label $w.font -text "Font:" 00059 ttk::label $w.style -text "Font style:" 00060 ttk::label $w.size -text "Size:" 00061 ttk::entry $w.efont -textvariable fontchooser::data($w,font) 00062 ttk::entry $w.estyle -textvariable fontchooser::data($w,style) 00063 ttk::entry $w.esize -textvariable fontchooser::data($w,size) -width 0 \ 00064 -validate key -validatecommand {string is double %P} 00065 00066 listbox $w.lfonts -listvariable fontchooser::data($w,fonts) -height 7 \ 00067 -borderwidth 0 -highlightthickness 0 -relief flat \ 00068 -yscrollcommand [list $w.sbfonts set] -height 7 -exportselection 0 00069 scroller::scroller $w.sbfonts -command [list $w.lfonts yview] 00070 listbox $w.lstyles -listvariable fontchooser::data($w,styles) -height 7 -exportselection 0 -relief flat 00071 listbox $w.lsizes -listvariable fontchooser::data($w,sizes) \ 00072 -borderwidth 0 -highlightthickness 0 -relief flat \ 00073 -yscroll [list $w.sbsizes set] -width 6 -height 7 -exportselection 0 00074 scroller::scroller $w.sbsizes -command [list $w.lsizes yview] 00075 00076 bind $w.lfonts <<ListboxSelect>> [list fontchooser::click $w font] 00077 bind $w.lstyles <<ListboxSelect>> [list fontchooser::click $w style] 00078 bind $w.lsizes <<ListboxSelect>> [list fontchooser::click $w size] 00079 00080 grid columnconfigure $w {0 3 6 9} -minsize 10 00081 grid columnconfigure $w {1 4 7} -weight 1 00082 grid x $w.font - x $w.style - x $w.size - x -sticky w 00083 grid x $w.efont - x $w.estyle - x $w.esize - x -sticky ew 00084 grid x $w.lfonts $w.sbfonts x $w.lstyles - x $w.lsizes $w.sbsizes x -sticky news 00085 00086 if {$opts(-effects)} { 00087 00088 ttk::labelframe $w.effects -text "Effects" 00089 ttk::checkbutton $w.effects.strike -variable fontchooser::data($w,strike) \ 00090 -text " Strikeout" -command [list fontchooser::show $w] 00091 ttk::checkbutton $w.effects.under -variable fontchooser::data($w,under) \ 00092 -text " Underline" -command [list fontchooser::show $w] 00093 00094 grid columnconfigure $w.effects 1 -weight 1 00095 grid $w.effects.strike -sticky w -padx 10 00096 grid $w.effects.under -sticky w -padx 10 00097 00098 grid $w.effects - x -sticky news -row 100 -column 1 00099 00100 } 00101 00102 ttk::labelframe $w.sample -text "Sample" 00103 ttk::label $w.sample.fsample -relief sunken 00104 set data($w,sample) [ttk::label $w.sample.fsample.sample -text "AaBbYyZz"] 00105 pack $w.sample.fsample -fill both -expand 1 -padx 10 -pady 10 -ipady 15 00106 pack $w.sample.fsample.sample -fill both -expand 1 00107 pack propagate $w.sample.fsample 0 00108 00109 grid rowconfigure $w 2 -weight 1 00110 grid rowconfigure $w 99 -minsize 30 00111 grid $w.sample - - - - -sticky news -row 100 -column 4 00112 grid rowconfigure $w 101 -minsize 30 00113 00114 trace variable fontchooser::data($w,size) w fontchooser::tracer 00115 trace variable fontchooser::data($w,style) w fontchooser::tracer 00116 trace variable fontchooser::data($w,font) w fontchooser::tracer 00117 00118 configure $w $opts(-default) 00119 00120 if {$opts(-mono) eq ""} { 00121 highlight $w $opts(-highlight) 00122 } 00123 00124 bind $w <Destroy> [list fontchooser::destroy $w] 00125 00126 return $w 00127 00128 } 00129 00130 ###################################################################### 00131 # Configures the font chooser widget. 00132 proc configure {w {defaultFont ""}} { 00133 00134 variable data 00135 00136 # Figure out the default font if one was not specified 00137 if {$defaultFont eq ""} { 00138 set defaultFont [[ttk::entry .___e] cget -font] 00139 ::destroy .___e 00140 } 00141 00142 array set F [font actual $defaultFont] 00143 00144 set data($w,font) $F(-family) 00145 set data($w,size) $F(-size) 00146 set data($w,strike) $F(-overstrike) 00147 set data($w,under) $F(-underline) 00148 set data($w,style) "Regular" 00149 if {($F(-weight) eq "bold") && ($F(-slant) eq "italic")} { 00150 set data($w,style) "Bold Italic" 00151 } elseif {$F(-weight) eq "bold"} { 00152 set data($w,style) "Bold" 00153 } elseif {$F(-slant) eq "italic"} { 00154 set data($w,style) "Italic" 00155 } 00156 00157 # Update the UI 00158 foreach var [list font style size] { 00159 tracer data $w,$var w 00160 } 00161 00162 # Display the result 00163 show $w 00164 00165 } 00166 00167 ###################################################################### 00168 # Highlights the fonts in the font list that are of a specific type. 00169 proc highlight {w highlight} { 00170 00171 variable data 00172 00173 if {$highlight ne ""} { 00174 00175 set hfonts [find_font_class $highlight] 00176 set i 0 00177 00178 foreach f $data($w,fonts) { 00179 if {[lsearch $hfonts $f] != -1} { 00180 $w.lfonts itemconfigure $i -foreground blue 00181 } 00182 incr i 00183 } 00184 00185 } 00186 00187 } 00188 00189 ###################################################################### 00190 # Called when the widget is destroyed. 00191 proc destroy {w} { 00192 00193 variable data 00194 00195 array unset data $w,* 00196 00197 trace remove variable fontchooser::data($w,size) write fontchooser::tracer 00198 trace remove variable fontchooser::data($w,style) write fontchooser::tracer 00199 trace remove variable fontchooser::data($w,font) write fontchooser::tracer 00200 00201 } 00202 00203 ###################################################################### 00204 # Called when one of the listboxes are clicked. 00205 proc click {w who} { 00206 00207 variable data 00208 00209 # Update the setting 00210 set data($w,$who) [$w.l${who}s get [$w.l${who}s curselection]] 00211 00212 } 00213 00214 ###################################################################### 00215 # Called when one of the font variables are written to. Updates the UI. 00216 proc tracer {var1 var2 op} { 00217 00218 variable data 00219 00220 lassign [split $var2 ,] w var 00221 00222 # Clear the selection 00223 $w.l${var}s selection clear 0 end 00224 00225 # Find the exact (or closest) font match and get its index 00226 set value [string tolower $data($w,$var)] 00227 if {[set n [lsearch -exact $data($w,${var}s,lcase) $value]] == -1} { 00228 if {[set n [lsearch -glob $data($w,${var}s,lcase) "$value*"]] == -1} { 00229 return 00230 } 00231 } 00232 00233 # Set the value 00234 set data($w,$var) [lindex $data($w,${var}s) $n] 00235 00236 # Update the UI 00237 $w.e$var icursor end 00238 $w.e$var selection clear 00239 $w.l${var}s selection set $n 00240 $w.l${var}s see $n 00241 00242 # Display the font 00243 show $w 00244 00245 } 00246 00247 ###################################################################### 00248 # Displays a sample of the selection options and generates the 00249 # <<FontChanged>> virtual event. 00250 proc show {w} { 00251 00252 variable data 00253 00254 set result [list -family $data($w,font) -size $data($w,size)] 00255 00256 switch $data($w,style) { 00257 "Bold" { lappend result -weight bold } 00258 "Italic" { lappend result -slant italic } 00259 "Bold Italic" { lappend result -weight bold -slant italic } 00260 } 00261 00262 if {$data($w,strike)} { lappend result -overstrike 1 } 00263 if {$data($w,under)} { lappend result -underline 1 } 00264 00265 # Display the sampled result and generate the FontChanged event 00266 if {![catch { $data($w,sample) config -font $result }]} { 00267 event generate $w <<FontChanged>> -data $result 00268 } 00269 00270 } 00271 00272 ###################################################################### 00273 # Returns the font families that match the given type. 00274 proc find_font_class {{type mono}} { 00275 00276 set fm [list] 00277 set fv [list] 00278 foreach f [font families] { 00279 if {[font measure "{$f} 8" "A"] == [font measure "{$f} 8" "."]} { 00280 lappend fm $f 00281 } else { 00282 lappend fv $f 00283 } 00284 } 00285 00286 return [expr {($type eq "mono") ? $fm : $fv}] 00287 00288 } 00289 00290 } 00291 00292 ###################################################################### 00293 # Creates a font chooser window. 00294 proc fontchooser {args} { 00295 00296 array set opts [list \ 00297 -parent . \ 00298 -initialfont $fontchooser::default_font \ 00299 -title "" \ 00300 -mono "" \ 00301 -styles "" \ 00302 -effects 1 \ 00303 ] 00304 array set opts $args 00305 00306 set ::fontchooser_value "" 00307 00308 toplevel .fontwin 00309 wm title .fontwin $opts(-title) 00310 wm transient .fontwin $opts(-parent) 00311 wm resizable .fontwin 0 0 00312 00313 fontchooser::create .fontwin.fc -effects $opts(-effects) -default $opts(-initialfont) -highlight mono -mono $opts(-mono) -styles $opts(-styles) 00314 00315 bind .fontwin.fc <<FontChanged>> { 00316 set ::fontchooser_value %d 00317 .fontwin.bf.choose configure -state normal 00318 } 00319 00320 ttk::frame .fontwin.bf 00321 ttk::button .fontwin.bf.choose -style BButton -text "Choose" -width 6 -command { 00322 destroy .fontwin 00323 } -state disabled 00324 ttk::button .fontwin.bf.cancel -style BButton -text "Cancel" -width 6 -command { 00325 set ::fontchooser_value "" 00326 destroy .fontwin 00327 } 00328 00329 pack .fontwin.bf.cancel -side right -padx 2 -pady 2 00330 pack .fontwin.bf.choose -side right -padx 2 -pady 2 00331 00332 pack .fontwin.fc -fill both -expand yes 00333 pack .fontwin.bf -fill x 00334 00335 fontchooser::show .fontwin.fc 00336 00337 tkwait window .fontwin 00338 00339 return $::fontchooser_value 00340 00341 }