home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1992 #27 / NN_1992_27.iso / spool / comp / lang / tcl / 1889 < prev    next >
Encoding:
Text File  |  1992-11-19  |  2.8 KB  |  96 lines
  1. Newsgroups: comp.lang.tcl
  2. Path: sparky!uunet!newsgate.watson.ibm.com!yktnews!admin!ghostwind!shmdgljd
  3. From: shmdgljd@rchland.vnet.ibm.com (Jay Schmidgall)
  4. Subject: tkfonts, a font browser in tk
  5. Sender: news@rchland.ibm.com
  6. Message-ID: <1992Nov19.150554.25365@rchland.ibm.com>
  7. Date: Thu, 19 Nov 1992 15:05:54 GMT
  8. Reply-To: jay@vnet.ibm.com
  9. Disclaimer: This posting represents the poster's views, not necessarily those of IBM
  10. Nntp-Posting-Host: ghostwind.rchland.ibm.com
  11. Organization: IBM Rochester, MN
  12. Lines: 82
  13.  
  14. Uses xlsfonts to get a list of available fonts.  Kludgy, but it works.
  15. Took a while to figure out how to insert the list of fonts into a listbox
  16. all at once rather than iterating over the list (which took a long time).
  17. Simple once I figured it out.
  18.  
  19. Only shows characters I could easily type in the selected font.
  20. --------- Cut ---------------------------------------------------------
  21. #!/usr/contrib/bin/wish -f
  22.  
  23. proc showfont { t args } {
  24.     global text
  25.     set w ".d$t"
  26.     toplevel $w
  27.     wm title $w $args
  28.     set pos [expr [winfo x .]+[winfo width .]]+[winfo y .]
  29.     wm geometry $w 400x200+$pos
  30.     wm maxsize $w 1024 1024
  31.     button $w.close -text Close -command "destroy $w"
  32.  
  33.     scrollbar $w.yscroll \
  34.         -command "$w.t1 yview" \
  35.         -relief raised
  36.     text $w.t1 -font $args \
  37.         -yscrollcommand "$w.yscroll set"
  38.     $w.t1 insert end $text
  39.  
  40.     pack  append $w \
  41.         $w.close {top fillx} \
  42.         $w.yscroll {left filly} \
  43.         $w.t1 {top expand fill}
  44. }
  45.  
  46. wm maxsize . 1024 1024
  47. wm geometry . 460x400
  48.  
  49. button .quit -text Quit -command { destroy . }
  50.  
  51. frame .frame
  52.  
  53. scrollbar .frame.yscroll \
  54.     -command ".frame.list yview" \
  55.     -relief raised
  56.  
  57. scrollbar .frame.xscroll \
  58.     -command ".frame.list xview" \
  59.     -relief raised \
  60.     -orient horizontal
  61.  
  62. listbox .frame.list \
  63.     -yscrollcommand ".frame.yscroll set" \
  64.     -xscrollcommand ".frame.xscroll set" \
  65.     -font 7x13b \
  66.     -relief flat
  67.  
  68. tk_listboxSingleSelect .frame.list
  69. bind .frame.list <ButtonRelease-1> \
  70.     { showfont %t [%W get [%W curselection]] }
  71.  
  72. pack append .frame \
  73.     .frame.yscroll {left filly} \
  74.     .frame.xscroll {bottom fillx} \
  75.     .frame.list    {expand fill}
  76.  
  77. set text \
  78. "~!@#\$%^&*()_+-={}|:\"<>?[]\\;',./`\n\
  79. 1234567890\n\
  80. abcdefghijklmnopqrstuvwxyz\n\
  81. ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  82.  
  83. pack append .\
  84.     .quit   {top fillx} \
  85.     .frame  {top expand fill}
  86.  
  87. # Have to wrap {} around font names for cases
  88. # where the name contains spaces
  89. catch { exec xlsfonts | awk {{ print "{"$0"}" }} } fonts
  90. regsub -all \n $fonts " " fonts
  91. eval .frame.list insert end $fonts
  92. ------------- Cut -------------------------------------------------------
  93. -- 
  94. : jay          jay@vnet.ibm.com    My opinions and ideas, not my employer's.
  95. : shmdgljd@rchland.vnet.ibm.com    (c) Copyright 1992.  All rights reserved.
  96.