Posted to tcl by kbk at Sun Jan 25 01:17:37 GMT 2009view raw

  1. package require Tk
  2. set fontlist "8 5 10 9 6 11 10 6 13 12 7 15 14 8 17 16 10 20 18 11 22 24 14 30 30 18 37 36 22 45"
  3. foreach {size width height} $fontlist {
  4. font create font$size -family {Courier New} -size [expr {-$height}]
  5. while {[font measure font$size M] > $width} {
  6. incr height -1
  7. font configure font$size -size [expr {-$height}]
  8. }
  9. }
  10.  
  11. grid [canvas .c -width 300 -height 30]
  12.  
  13. proc paintText {canvas x y string font width height} {
  14. set xx $x
  15. set yy $y
  16. foreach c [split $string {}] {
  17. if {$c eq "\n"} {
  18. incr yy $height
  19. set xx $x
  20. } else {
  21. $canvas create text $xx $yy -text $c -anchor nw -font $font
  22. incr xx $width
  23. }
  24. }
  25. }
  26.  
  27. paintText .c 10 5 Testing font16 10 20