"Fossies" - the Fresh Open Source Software Archive

Member "tkscanfax1/getfont.tcl" (22 Jul 2003, 6312 Bytes) of package /linux/misc/old/tkscanfax-1.1.8.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Tcl/Tk source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "getfont.tcl" see the Fossies "Dox" file reference documentation.

    1 # modified by Masaki Shnomiya   5 Oct 2002
    2 # originally from Jun Wakaya 2000
    3 # ISBN4-7978-2014-4 
    4 
    5 #set gf_fontName ""
    6 #set gf_fontSize 10
    7 set  gf_fontWeight ""
    8 set gf_fontSlant ""
    9 #set m(ok) "OK"
   10 # set m(cancel) "Cancel"
   11 # set fax(locale) "ja"
   12 
   13 #--------------------------------------------------------------------------
   14 # edit font attribute
   15 #--------------------------------------------------------------------------
   16 
   17 proc edit_font { font } {
   18        global fax m confwindow gf_fontName gf_fontSize gf_fontWeight gf_fontSlant
   19 
   20        if [string match  {-*} $font ] {
   21            set fl [split $font {-}]
   22            set f [lindex $fl 2]
   23            set s [lindex $fl 7]
   24            set weight [lindex $fl 3]
   25            set slant [lindex $fl 4]
   26        } else {
   27            set fl [split $font { }]
   28            set f [lindex $fl 0]
   29            set s [lindex $fl 1] 
   30            set weight [lindex $fl 1]
   31            set slant [lindex $fl 2]
   32        }
   33 # for debygging
   34 #text_viewer "edit_font" "Font family:$f\nFont size:$s\nFont Weight:$weight\nSlant:$slant"
   35 
   36        if { $f == "" } { set f "courier" }
   37        if { $s < 8 } { set s 12 }
   38        if [string match b* $weight] { set weight bold } else { set weight normal }
   39        if [string match i* $slant] { set slant italic } else { set slant roman } 
   40        set gf_fontName $f
   41        set gf_fontSize $s
   42        set gf_fontWeight $weight
   43        set gf_fontSlant $slant
   44 
   45        return "[tk_GetFont $confwindow.gf ]"
   46 }
   47 
   48 proc tk_GetFont {w} {
   49         global fax m
   50     global tcl_platform gf_font gf_fontName gf_fontSize gf_fontWeight gf_fontSlant \
   51                   gf_weightList gf_slantList gf_weight gf_slant gf_savesize
   52 
   53     if {[winfo exists $w]} return
   54 
   55     toplevel $w
   56     grab $w
   57 
   58     set locale $fax(locale)
   59         set myfont   {defaultgui 12}
   60         set buttonfont   {Mincho:Helvetica-Bold-12}
   61         set sampletext "ABCDE fghij"
   62         switch -- $locale {
   63               "ja" {set sampletext "$sampletext ܸ" }
   64               "ko" {set sampletext "$sampletext ѱ" }
   65               default {}
   66          }
   67          set startfont "$gf_fontName $gf_fontSize $gf_fontWeight $gf_fontSlant"
   68         set gf_weightList [list normal bold]
   69         set gf_slantList [list roman italic]
   70         set gf_font ""
   71     set gf_savesize 0
   72 
   73 #   if {$tcl_platform(platform)=="macintosh"} {
   74         wm title $w "Choose Font"
   75 #   } else {
   76 #   }
   77 
   78     pack [frame $w.u] -fill both -padx 5 -pady 5
   79     pack [frame $w.m -relief sunken -bd 1] -fill both -padx 10 -pady 5
   80     pack [frame $w.l] -fill both -padx 5 -pady 5
   81 
   82     pack [frame $w.u.l -relief sunken -bd 1] \
   83         [frame $w.u.r -relief sunken -bd 1] \
   84         -fill both -side left -padx 5
   85 
   86     pack [listbox $w.u.l.lb -yscrollcommand "$w.u.l.sb set" \
   87         -bg #cfcfcf -relief flat -width 32 -font $myfont \
   88         -selectmode single -takefocus 0] \
   89         [scrollbar $w.u.l.sb -command "$w.u.l.lb yview"] \
   90     -fill both -side left
   91 
   92     pack [scale $w.u.r.s -orient vertical -from 8 -to 72 -relief flat \
   93         -variable gf_fontSize -command "gf_preview_size $w"] -fill both -side left
   94 
   95         pack [checkbutton $w.m.b -text "Bold" -font "$myfont bold" -variable gf_weight \
   96             -command "gf_preview_font $w"] \
   97                 [checkbutton $w.m.i -text "Italic" -font "$myfont normal italic"  -variable gf_slant \
   98             -command "gf_preview_font $w"] \
   99              -side left -fill both -padx 5
  100 
  101         pack [label $w.l.text -text $sampletext -font $startfont  -relief groove -bd 1 -padx 5] \
  102         -side left -fill both -padx 5
  103     pack [button $w.l.cancel -text $m(cancel) -font $buttonfont \
  104                  -command "gf_cancel $w"] \
  105         [button $w.l.ok -text $m(ok)  -font $buttonfont \
  106                  -command "gf_ok $w" \
  107           -default active] \
  108         -side right -fill both -padx 5
  109     focus $w.l.ok
  110 
  111     set gf_fBox $w.u.l.lb
  112         bind $gf_fBox <ButtonRelease-1> "gf_preview_font $w"
  113 
  114         set gf_fontList [font families]
  115         set gf_fontList [concat $gf_fontList [font names]]
  116     set gf_fontList [lsort $gf_fontList]
  117 
  118     foreach i $gf_fontList {
  119         $gf_fBox insert end $i
  120     }
  121 
  122         set fontkey [string trimleft [string trimright $gf_fontName \} ] \} ]
  123         set fontnumber [lsearch -exact $gf_fontList $fontkey]
  124         if { $fontnumber <0 } { set fontnumber 0 }
  125     $gf_fBox selection set $fontnumber
  126         $gf_fBox see $fontnumber
  127 
  128         set gf_weight [lsearch -exact $gf_weightList $gf_fontWeight]
  129         if { $gf_weight < 0 } { set weight 0 }   
  130         set gf_slant [lsearch -exact $gf_slantList $gf_fontSlant]        
  131         if { $gf_slant < 0 } { set slant 0 }
  132 
  133     gf_preview_font $w
  134 
  135     tkwait window $w
  136         return "$gf_font"
  137 }
  138 
  139 proc gf_ok {w} {
  140     global gf_font 
  141         set gf_font "[gf_preview_font $w]"
  142     destroy $w
  143         return "gf_font" 
  144 }
  145 
  146 proc gf_cancel {w} {
  147     global gf_font 
  148     destroy $w
  149         set gf_font ""
  150         return ""
  151 }
  152 
  153 proc gf_preview_size { w n } {
  154         gf_preview_font  $w
  155 }
  156 
  157 proc gf_preview_font {w} {
  158     global gf_font gf_fontName gf_fontSize gf_fontWeight gf_fontSlant
  159         global gf_weightList gf_slantList gf_weight gf_slant gf_savesize gf_saveweight gf_saveslant
  160 
  161     set gf_fBox $w.u.l.lb
  162 
  163        foreach i [list $w.u.r.s $w.m.b $w.m.i] {
  164               $i configure -state normal
  165        }
  166     if { $gf_savesize > 0 } {
  167         set gf_fontSize $gf_savesize
  168         set gf_weight   $gf_saveweight
  169         set gf_slant $gf_saveslant
  170         set gf_savesize 0
  171     }
  172 
  173     set gf_fontName [$gf_fBox get [$gf_fBox curselection]]
  174         set gf_fontWeight [lindex $gf_weightList $gf_weight]
  175         set gf_fontSlant [lindex $gf_slantList $gf_slant]
  176     
  177     switch -glob -- $gf_fontName {
  178          {*-[0-9][0-9]} {
  179                 set gf_font "$gf_fontName"
  180                 set gf_savesize $gf_fontSize
  181                 set gf_saveweight   $gf_weight
  182                 set gf_saveslant    $gf_slant
  183                 set tempfl  [split $gf_font {-} ]
  184                 set tempsize [lindex $tempfl end]
  185                 if { [lsearch -glob $tempfl {[Bb]old}] > 0 } {set gf_weight 1} else { set gf_weight 0 }
  186                 if { [lsearch -glob $tempfl {[Ii]talic}] > 0 } {set gf_slant 1 } else { set gf_slant 0 }
  187                 set gf_fontSize $tempsize
  188                 foreach i [list $w.u.r.s $w.m.b $w.m.i] {
  189                     $i configure -state disabled
  190                 }
  191             }
  192                {*[ ]*}           { set gf_font  "\{$gf_fontName\} $gf_fontSize $gf_fontWeight $gf_fontSlant"  }
  193                default         { set gf_font  "$gf_fontName $gf_fontSize $gf_fontWeight $gf_fontSlant"   }   }
  194         $w.l.text configure -font "$gf_font"
  195         return "$gf_font"
  196 }