Label auto-adaptable

 

ulis, 2005-06-28. Un label dont le texte prend toute la place.

Pourquoi

Au départ, c'est un des 3 problèmes du Contest Tcl de 2002. C'est aussi un widget qui peut être utile. Et comme la solution de Brent Welch (le seul lauréat et vainqueur) ne marche pas sous mon Windows Server 2003...

Comment

Toujours avec un canvas. Et en calculant la hauteur réelle du texte en simulant la justification.

Le widget

  # contest

  package require Tk

  proc contest {w family text} \
  {
    # create widget
    set font [font create -family $family]
    canvas $w
    $w create text 0 0 -anchor center \
      -tags text -justify center \
      -text $text -font $font
    # bind resizing
    bind $w <Configure> {resize %W}
  }

  proc resize {w} \
  {
    # on resizing
    set width [winfo width .]
    set height [winfo height .]
    set font [$w itemcget text -font]
    # get actual text height
    set th [height $w $width $font]
    if {$th != $height} \
    {
      set size [font actual $font -size]
      if {$th < $height} \
      {
        # growing
        while {$th < $height + 2} \
        {
          # increment font size
          font config $font -size [incr size]
          # compute actual height
          set th [height $w $width $font]
        }
        if {$th != $height} \
        {
          # a bit too long
          font config $font -size [incr size -1]
          set th [height $w $width $font]
        }
      } \
      else \
      {
        # shrinking
        while {$th > $height + 2} \
        {
          # decrement font size
          font config $font -size [incr size -1]
          # compute actual height
          set th [height $w $width $font]
        }
      }
    }
    # set justifyied text & adjusted font
    $w itemconfig text -font $font \
      -text [join [lines $w $width $font] \n]
    # center to avoid too large border
    center $w
  }

  proc center {w} \
  {
    # center text
    set width [winfo width $w]
    set height [winfo height $w]
    set xc [expr {$width / 2}]
    set yc [expr {$height / 2}]
    $w coord text $xc $yc
  }

  proc height {w width font} \
  {
    # compute text height
    set lh [font metrics $font -linespace]
    set count [llength [lines $w $width $font]]
    return [expr {$lh * $count}]
  }

  proc lines {w width font} \
  {
    # justify text to know how many lines
    set text [string map {\n {}} [$w itemcget text -text]]
    set lines [list]
    set line ""
    while {$text != ""} \
    {
      set ch [string index $text 0]
      if {[font measure $font "$line$ch"] > $width} \
      {
        # too large
        set n [string last " " $line]
        if {$n > -1} \
        {
          set text "[string range $line [expr {$n + 1}] end]$text"
          set line [string range $line 0 $n]
        }
        lappend lines $line
        set line ""
      } \
      else \
      {
        # not enough
        set line "$line$ch"
        set text [string range $text 1 end]
      }
    }
    # add last line
    if {$line != ""} { lappend lines $line }
    # return list of lines
    return $lines
  }

  # try
  contest .c Arial "Tcl2002 programming contest: problem 2"
  pack .c -fill both -expand 1
  .c config -width 150 -height 150

Voir aussi

Catégorie Exemple | Catégorie Widget