home *** CD-ROM | disk | FTP | other *** search
/ PC World 2002 May / PCWorld_2002-05_cd.bin / Software / TemaCD / activetcltk / ActiveTcl8.3.4.1-8.win32-ix86.exe / ActiveTcl8.3.4.1-win32-ix86 / lib / bwidget1.3.0 / font.tcl < prev    next >
Encoding:
Text File  |  2001-10-22  |  16.4 KB  |  495 lines
  1. # ------------------------------------------------------------------------------
  2. #  font.tcl
  3. #  This file is part of Unifix BWidget Toolkit
  4. # ------------------------------------------------------------------------------
  5. #  Index of commands:
  6. #     - SelectFont::create
  7. #     - SelectFont::configure
  8. #     - SelectFont::cget
  9. #     - SelectFont::_draw
  10. #     - SelectFont::_destroy
  11. #     - SelectFont::_modstyle
  12. #     - SelectFont::_update
  13. #     - SelectFont::_getfont
  14. #     - SelectFont::_init
  15. # ------------------------------------------------------------------------------
  16.  
  17. namespace eval SelectFont {
  18.     Dialog::use
  19.     LabelFrame::use
  20.     ScrolledWindow::use
  21.  
  22.     Widget::declare SelectFont {
  23.         {-title        String        "Font selection" 0}
  24.         {-parent    String        "" 0}
  25.         {-background    TkResource    "" 0 frame}
  26.  
  27.         {-type        Enum        dialog        0 {dialog toolbar}}
  28.         {-font        TkResource    ""            0 label}
  29.     {-families    String        "all"         1}
  30.     {-querysystem    Boolean        1             0}
  31.     {-styles    String        "bold italic underline overstrike" 1}
  32.         {-command    String        ""            0}
  33.         {-sampletext    String        "Sample Text" 0}
  34.         {-bg        Synonym        -background}
  35.     }
  36.  
  37.     proc ::SelectFont { path args } { 
  38.     return [eval SelectFont::create $path $args] 
  39.     }
  40.     proc use {} {}
  41.  
  42.     variable _families
  43.     variable _styleOff
  44.     array set _styleOff [list bold normal italic roman]
  45.     variable _sizes     {4 5 6 7 8 9 10 11 12 13 14 15 16 \
  46.         17 18 19 20 21 22 23 24}
  47.     
  48.     # Set up preset lists of fonts, so the user can avoid the painfully slow
  49.     # loadfont process if desired.
  50.     if { [string equal $::tcl_platform(platform) "windows"] } {
  51.     set presetVariable [list    \
  52.         7x14            \
  53.         Arial            \
  54.         {Arial Narrow}        \
  55.         {Lucida Sans}        \
  56.         {MS Sans Serif}        \
  57.         {MS Serif}        \
  58.         {Times New Roman}    \
  59.         ]
  60.     set presetFixed    [list    \
  61.         6x13            \
  62.         {Courier New}        \
  63.         FixedSys        \
  64.         Terminal        \
  65.         ]
  66.     set presetAll      [list    \
  67.         6x13            \
  68.         7x14            \
  69.         Arial            \
  70.         {Arial Narrow}        \
  71.         {Courier New}        \
  72.         FixedSys        \
  73.         {Lucida Sans}        \
  74.         {MS Sans Serif}        \
  75.         {MS Serif}        \
  76.         Terminal        \
  77.         {Times New Roman}    \
  78.         ]
  79.     } else {
  80.     set presetVariable [list    \
  81.         helvetica        \
  82.         lucida            \
  83.         lucidabright        \
  84.         {times new roman}    \
  85.         ]
  86.     set presetFixed    [list    \
  87.         courier            \
  88.         fixed            \
  89.         {lucida typewriter}    \
  90.         screen            \
  91.         serif            \
  92.         terminal        \
  93.         ]
  94.     set presetAll      [list    \
  95.         courier            \
  96.         fixed            \
  97.         helvetica        \
  98.         lucida            \
  99.         lucidabright        \
  100.         {lucida typewriter}    \
  101.         screen            \
  102.         serif            \
  103.         terminal        \
  104.         {times new roman}    \
  105.         ]
  106.     }
  107.     array set _families [list \
  108.         presetvariable    $presetVariable    \
  109.         presetfixed        $presetFixed    \
  110.         presetall        $presetAll    \
  111.         ]
  112.         
  113.     variable _widget
  114. }
  115.  
  116.  
  117. # ----------------------------------------------------------------------------
  118. #  Command SelectFont::create
  119. # ----------------------------------------------------------------------------
  120. proc SelectFont::create { path args } {
  121.     variable _families
  122.     variable _sizes
  123.     variable $path
  124.     upvar 0  $path data
  125.  
  126.     # Initialize the internal rep of the widget options
  127.     Widget::init SelectFont "$path#SelectFont" $args
  128.  
  129.     if { ![info exists _families(all)] && \
  130.         [Widget::getoption "$path#SelectFont" -querysystem] } {
  131.         loadfont
  132.     }
  133.  
  134.     set bg [Widget::getoption "$path#SelectFont" -background]
  135.     set _styles [Widget::getoption "$path#SelectFont" -styles]
  136.     if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
  137.         Dialog::create $path -modal local -default 0 -cancel 1 -background $bg \
  138.             -title  [Widget::getoption "$path#SelectFont" -title] \
  139.             -parent [Widget::getoption "$path#SelectFont" -parent]
  140.  
  141.         set frame [Dialog::getframe $path]
  142.         set topf  [frame $frame.topf -relief flat -borderwidth 0 -background $bg]
  143.  
  144.         set labf1 [LabelFrame::create $topf.labf1 -text "Font" -name font \
  145.                        -side top -anchor w -relief flat -background $bg]
  146.         set sw    [ScrolledWindow::create [LabelFrame::getframe $labf1].sw \
  147.                        -background $bg]
  148.         set lbf   [listbox $sw.lb \
  149.                        -height 5 -width 25 -exportselection false -selectmode browse]
  150.         ScrolledWindow::setwidget $sw $lbf
  151.         LabelFrame::configure $labf1 -focus $lbf
  152.     if { [Widget::getoption "$path#SelectFont" -querysystem] } {
  153.         set fam [Widget::getoption "$path#SelectFont" -families]
  154.     } else {
  155.         set fam "preset"
  156.         append fam [Widget::getoption "$path#SelectFont" -families]
  157.     }
  158.         eval $lbf insert end $_families($fam)
  159.         set script "set SelectFont::$path\(family\) \[%W curselection\]; SelectFont::_update $path"
  160.         bind $lbf <ButtonRelease-1> $script
  161.         bind $lbf <space>           $script
  162.         pack $sw -fill both -expand yes
  163.  
  164.         set labf2 [LabelFrame::create $topf.labf2 -text "Size" -name size \
  165.                        -side top -anchor w -relief flat -background $bg]
  166.         set sw    [ScrolledWindow::create [LabelFrame::getframe $labf2].sw \
  167.                        -scrollbar vertical -background $bg]
  168.         set lbs   [listbox $sw.lb \
  169.                        -height 5 -width 6 -exportselection false -selectmode browse]
  170.         ScrolledWindow::setwidget $sw $lbs
  171.         LabelFrame::configure $labf2 -focus $lbs
  172.         eval $lbs insert end $_sizes
  173.         set script "set SelectFont::$path\(size\) \[%W curselection\]; SelectFont::_update $path"
  174.         bind $lbs <ButtonRelease-1> $script
  175.         bind $lbs <space>           $script
  176.         pack $sw -fill both -expand yes
  177.  
  178.         set labf3 [LabelFrame::create $topf.labf3 -text "Style" -name style \
  179.                        -side top -anchor w -relief sunken -bd 1 -background $bg]
  180.         set subf  [LabelFrame::getframe $labf3]
  181.         foreach st $_styles {
  182.             set name [lindex [BWidget::getname $st] 0]
  183.             if { $name == "" } {
  184.                 set name "[string toupper [string index $name 0]][string range $name 1 end]"
  185.             }
  186.             checkbutton $subf.$st -text $name \
  187.                 -variable   SelectFont::$path\($st\) \
  188.                 -background $bg \
  189.                 -command    "SelectFont::_update $path"
  190.             bind $subf.$st <Return> break
  191.             pack $subf.$st -anchor w
  192.         }
  193.         LabelFrame::configure $labf3 -focus $subf.[lindex $_styles 0]
  194.  
  195.         pack $labf1 -side left -anchor n -fill both -expand yes
  196.         pack $labf2 -side left -anchor n -fill both -expand yes -padx 8
  197.         pack $labf3 -side left -anchor n -fill both -expand yes
  198.  
  199.         set botf [frame $frame.botf -width 100 -height 50 \
  200.                       -bg white -bd 0 -relief flat \
  201.                       -highlightthickness 1 -takefocus 0 \
  202.                       -highlightbackground black \
  203.                       -highlightcolor black]
  204.  
  205.         set lab  [label $botf.label \
  206.                       -background white -foreground black \
  207.                       -borderwidth 0 -takefocus 0 -highlightthickness 0 \
  208.                       -text [Widget::getoption "$path#SelectFont" -sampletext]]
  209.         place $lab -relx 0.5 -rely 0.5 -anchor c
  210.  
  211.         pack $topf -pady 4 -fill both -expand yes
  212.         pack $botf -pady 4 -fill x
  213.  
  214.         Dialog::add $path -name ok
  215.         Dialog::add $path -name cancel
  216.  
  217.         set data(label) $lab
  218.         set data(lbf)   $lbf
  219.         set data(lbs)   $lbs
  220.  
  221.         _getfont $path
  222.  
  223.         proc ::$path { cmd args } "return \[eval SelectFont::\$cmd $path \$args\]"
  224.  
  225.         return [_draw $path]
  226.     } else {
  227.     if { [Widget::getoption "$path#SelectFont" -querysystem] } {
  228.         set fams [Widget::getoption "$path#SelectFont" -families]
  229.     } else {
  230.         set fams "preset"
  231.         append fams [Widget::getoption "$path#SelectFont" -families]
  232.     }
  233.         frame $path -relief flat -borderwidth 0 -background $bg
  234.         bind $path <Destroy> "SelectFont::_destroy $path"
  235.         set lbf [ComboBox::create $path.font \
  236.                      -highlightthickness 0 -takefocus 0 -background $bg \
  237.                      -values   $_families($fams) \
  238.                      -textvariable SelectFont::$path\(family\) \
  239.                      -editable 0 \
  240.                      -modifycmd "SelectFont::_update $path"]
  241.         set lbs [ComboBox::create $path.size \
  242.                      -highlightthickness 0 -takefocus 0 -background $bg \
  243.                      -width    4 \
  244.                      -values   $_sizes \
  245.                      -textvariable SelectFont::$path\(size\) \
  246.                      -editable 0 \
  247.                      -modifycmd "SelectFont::_update $path"]
  248.         pack $lbf -side left -anchor w
  249.         pack $lbs -side left -anchor w -padx 4
  250.         foreach st $_styles {
  251.             button $path.$st \
  252.                 -highlightthickness 0 -takefocus 0 -padx 0 -pady 0 -bd 2 \
  253.                 -background $bg \
  254.                 -image  [Bitmap::get $st] \
  255.                 -command "SelectFont::_modstyle $path $st"
  256.             pack $path.$st -side left -anchor w
  257.         }
  258.         set data(label) ""
  259.         set data(lbf)   $lbf
  260.         set data(lbs)   $lbs
  261.         _getfont $path
  262.  
  263.         rename $path ::$path:cmd
  264.         proc ::$path { cmd args } "return \[eval SelectFont::\$cmd $path \$args\]"
  265.     }
  266.  
  267.     return $path
  268. }
  269.  
  270.  
  271. # ----------------------------------------------------------------------------
  272. #  Command SelectFont::configure
  273. # ----------------------------------------------------------------------------
  274. proc SelectFont::configure { path args } {
  275.     set _styles [Widget::getoption "$path#SelectFont" -styles]
  276.  
  277.     set res [Widget::configure "$path#SelectFont" $args]
  278.  
  279.     if { [Widget::hasChanged "$path#SelectFont" -font font] } {
  280.         _getfont $path
  281.     }
  282.     if { [Widget::hasChanged "$path#SelectFont" -background bg] } {
  283.         switch -- [Widget::getoption "$path#SelectFont" -type] {
  284.             dialog {
  285.                 Dialog::configure $path -background $bg
  286.                 set topf [Dialog::getframe $path].topf
  287.                 $topf configure -background $bg
  288.                 foreach labf {labf1 labf2} {
  289.                     LabelFrame::configure $topf.$labf -background $bg
  290.                     set subf [LabelFrame::getframe $topf.$labf]
  291.                     ScrolledWindow::configure $subf.sw -background $bg
  292.                     $subf.sw.lb configure -background $bg
  293.                 }
  294.                 LabelFrame::configure $topf.labf3 -background $bg
  295.                 set subf [LabelFrame::getframe $topf.labf3]
  296.                 foreach w [winfo children $subf] {
  297.                     $w configure -background $bg
  298.                 }
  299.             }
  300.             toolbar {
  301.                 $path configure -background $bg
  302.                 ComboBox::configure $path.font -background $bg
  303.                 ComboBox::configure $path.size -background $bg
  304.                 foreach st $_styles {
  305.                     $path.$st configure -background $bg
  306.                 }
  307.             }
  308.         }
  309.     }
  310.     return $res
  311. }
  312.  
  313.  
  314. # ----------------------------------------------------------------------------
  315. #  Command SelectFont::cget
  316. # ----------------------------------------------------------------------------
  317. proc SelectFont::cget { path option } {
  318.     return [Widget::cget "$path#SelectFont" $option]
  319. }
  320.  
  321.  
  322. # ----------------------------------------------------------------------------
  323. #  Command SelectFont::loadfont
  324. # ----------------------------------------------------------------------------
  325. proc SelectFont::loadfont { } {
  326.     variable _families
  327.  
  328.     # initialize families
  329.     set _families(all) {}
  330.     set _families(fixed) {}
  331.     set _families(variable) {}
  332.     set lfont     [font families]
  333.     lappend lfont times courier helvetica
  334.     foreach font $lfont {
  335.         set family [font actual [list $font] -family]
  336.         if { [lsearch -exact $_families(all) $family] == -1 } {
  337.             lappend _families(all) $family
  338.         }
  339.     }
  340.     set _families(all) [lsort $_families(all)]
  341.     foreach family $_families(all) {
  342.     if { [font metrics [list $family] -fixed] } {
  343.         lappend _families(fixed) $family
  344.     } else {
  345.         lappend _families(variable) $family
  346.     }
  347.     }
  348.     return
  349. }
  350.  
  351.  
  352. # ----------------------------------------------------------------------------
  353. #  Command SelectFont::_draw
  354. # ----------------------------------------------------------------------------
  355. proc SelectFont::_draw { path } {
  356.     variable $path
  357.     upvar 0  $path data
  358.  
  359.     $data(lbf) selection clear 0 end
  360.     $data(lbf) selection set $data(family)
  361.     $data(lbf) activate $data(family)
  362.     $data(lbf) see $data(family)
  363.     $data(lbs) selection clear 0 end
  364.     $data(lbs) selection set $data(size)
  365.     $data(lbs) activate $data(size)
  366.     $data(lbs) see $data(size)
  367.     _update $path
  368.  
  369.     if { [Dialog::draw $path] == 0 } {
  370.         set result [Widget::getoption "$path#SelectFont" -font]
  371.     } else {
  372.         set result ""
  373.     }
  374.     unset data
  375.     Widget::destroy "$path#SelectFont"
  376.     destroy $path
  377.     return $result
  378. }
  379.  
  380.  
  381. # ----------------------------------------------------------------------------
  382. #  Command SelectFont::_destroy
  383. # ----------------------------------------------------------------------------
  384. proc SelectFont::_destroy { path } {
  385.     variable $path
  386.     upvar 0  $path data
  387.  
  388.     unset data
  389.     Widget::destroy "$path#SelectFont"
  390.     rename $path {}
  391. }
  392.  
  393.  
  394. # ----------------------------------------------------------------------------
  395. #  Command SelectFont::_modstyle
  396. # ----------------------------------------------------------------------------
  397. proc SelectFont::_modstyle { path style } {
  398.     variable $path
  399.     upvar 0  $path data
  400.  
  401.     if { $data($style) == 1 } {
  402.         $path.$style configure -relief raised
  403.         set data($style) 0
  404.     } else {
  405.         $path.$style configure -relief sunken
  406.         set data($style) 1
  407.     }
  408.     _update $path
  409. }
  410.  
  411.  
  412. # ----------------------------------------------------------------------------
  413. #  Command SelectFont::_update
  414. # ----------------------------------------------------------------------------
  415. proc SelectFont::_update { path } {
  416.     variable _families
  417.     variable _sizes
  418.     variable _styleOff
  419.     variable $path
  420.     upvar 0  $path data
  421.  
  422.     set type [Widget::getoption "$path#SelectFont" -type]
  423.     set _styles [Widget::getoption "$path#SelectFont" -styles]
  424.     if { [Widget::getoption "$path#SelectFont" -querysystem] } {
  425.     set fams [Widget::getoption "$path#SelectFont" -families]
  426.     } else {
  427.     set fams "preset"
  428.     append fams [Widget::getoption "$path#SelectFont" -families]
  429.     }
  430.     if { $type == "dialog" } {
  431.         set curs [$path:cmd cget -cursor]
  432.         $path:cmd configure -cursor watch
  433.     }
  434.     if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
  435.         set font [list \
  436.                       [lindex $_families($fams) $data(family)] \
  437.                       [lindex $_sizes $data(size)]]
  438.     } else {
  439.         set font [list $data(family) $data(size)]
  440.     }
  441.     foreach st $_styles {
  442.         if { $data($st) } {
  443.             lappend font $st
  444.         } else {
  445.         if { [info exists _styleOff($st)] } {
  446.         lappend font $_styleOff($st)
  447.         }
  448.     }
  449.     }
  450.     Widget::setoption "$path#SelectFont" -font $font
  451.     if { $type == "dialog" } {
  452.         $data(label) configure -font $font
  453.         $path:cmd configure -cursor $curs
  454.     } elseif { [set cmd [Widget::getoption "$path#SelectFont" -command]] != "" } {
  455.         uplevel \#0 $cmd
  456.     }
  457. }
  458.  
  459.  
  460. # ----------------------------------------------------------------------------
  461. #  Command SelectFont::_getfont
  462. # ----------------------------------------------------------------------------
  463. proc SelectFont::_getfont { path } {
  464.     variable _families
  465.     variable _sizes
  466.     variable $path
  467.     upvar 0  $path data
  468.  
  469.     array set font [font actual [Widget::getoption "$path#SelectFont" -font]]
  470.     set data(bold)    [expr {[string compare $font(-weight) "normal"] != 0}]
  471.     set data(italic)  [expr {[string compare $font(-slant)  "roman"]  != 0}]
  472.     set data(underline)  $font(-underline)
  473.     set data(overstrike) $font(-overstrike)
  474.     set _styles [Widget::getoption "$path#SelectFont" -styles]
  475.     if { [Widget::getoption "$path#SelectFont" -querysystem] } {
  476.     set fams [Widget::getoption "$path#SelectFont" -families]
  477.     } else {
  478.     set fams "preset"
  479.     append fams [Widget::getoption "$path#SelectFont" -families]
  480.     }
  481.     if { [Widget::getoption "$path#SelectFont" -type] == "dialog" } {
  482.         set idxf [lsearch $_families($fams) $font(-family)]
  483.         set idxs [lsearch $_sizes    $font(-size)]
  484.         set data(family) [expr {$idxf >= 0 ? $idxf : 0}]
  485.         set data(size)   [expr {$idxs >= 0 ? $idxs : 0}]
  486.     } else {
  487.         set data(family) $font(-family)
  488.         set data(size)   $font(-size)
  489.         foreach st $_styles {
  490.             $path.$st configure -relief [expr {$data($st) ? "sunken":"raised"}]
  491.         }
  492.     }
  493. }
  494.  
  495.