sframe

 

ulis, 24-10-2005. Un mini megawidget qui incorpore des ascenseurs à un widget frame.

  package require sframe
  sframe .sf -width 100 -height 250 -bg beige

Pourquoi

Pour ne pas refaire cent fois la même chose.


Comment

Les ascenseurs sont incorporés. Point.

Heu...

Les fonctions xview et yview sont simulées en Tcl.

Un premier frame contient : les ascenseurs et un deuxième frame. Qui contient : le frame qui contient : les widgets.

Le dernier frame (qui DOIT contenir les widgets) s'obtient par [$w frame].

(c'est compliqué à dire mais facile à utiliser : voir le test)


Le mini megawidget

c'est a scrolled frame (http://wiki.tcl.tk/AScrolledFrame) revu et corrigé par KJN (http://wiki.tcl.tk/KJN).

  if {[info exists ::sframe::version]} { return }

  namespace eval sframe \
  {
  # ##########################
  #
  # package sframe
    variable version 1.0
  #
  #   crée un widget frame avec ses ascenseurs
  #
  # --------------------------
  # (C) 2005, ulis
  # licence NOL (No Obligation Licence)
  # --------------------------
  # Changes (C) 2004, KJN
  # licence NOL (No Obligation Licence)
  # --------------------------
  # usage :
  #
  #   package require sframe
  #   sframe .sf -bg beige -width 200 -height 200
  #   pack [label [.sf frame].l -text ...]
  #   pack .sf -fill both -expand 1
  #   .sf yview moveto 1.0
  #
  # ##########################

    package require Tk
    package provide sframe $version

    namespace export sframe

    variable {}
    array set {} {}

    proc sframe {w args} \
    {
      variable {}
      # init internal data
      set ($w:vheight) 0
      set ($w:vwidth) 0
      set ($w:vtop) 0
      set ($w:vleft) 0
      set ($w:width)    0
      set ($w:height)   0
      frame $w
      canvas $w.sframe_h -width 100 -height 0 -highlightt 0
      canvas $w.sframe_v -width 0 -height 100 -highlightt 0
      frame $w.sframe_f
      frame $w.sframe_f.f
      scrollbar $w.sframe_hs -orient horizontal \
        -command [list ::sframe::xview $w]
      scrollbar $w.sframe_vs -orient vertical \
        -command [list ::sframe::yview $w]
      grid $w.sframe_v -row 0 -column 0 -sticky w -rowspan 2
      grid $w.sframe_h -row 0 -column 1 -sticky n -columnspan 2
      grid $w.sframe_f -row 1 -column 1 -sticky nsew
      grid $w.sframe_vs -row 1 -column 2 -sticky nse
      grid $w.sframe_hs -row 2 -column 1 -sticky sew
      grid rowconfigure $w 1 -weight 1
      grid columnconfigure $w 1 -weight 1
      place $w.sframe_f.f -in $w.sframe_f -x 0 -y 0
      rename $w ::sframe::_$w
      interp alias {} ::$w {} ::sframe::dispatch $w
      if {$args != ""} { uplevel 1 ::sframe::config $w $args }
      # bind <Configure>
      bind $w <Configure> [namespace code [list resize $w]]
      bind $w.sframe_f <Configure> [namespace code [list resize $w]]
      # return widget ref
      return $w
    }

    proc dispatch {w cmd args} \
    {
      puts "dispatch $w $cmd $args"
      switch -glob -- $cmd \
      {
        cge*  { uplevel 1 $w.sframe_f cget $args }
        con*  { uplevel 1 ::sframe::config $w $args }
        fra*  { return $w.sframe_f.f }
        xvi*  { uplevel 1 ::sframe::xview $w $args }
        yvi*  { uplevel 1 ::sframe::yview $w $args }
      }
    }

    proc config {w args} \
    {
      set n [llength $args]
      if {$n < 2} { uplevel 1 $w.sframe_f config $args } \
      else \
      {
        foreach {key value} $args \
        {
          switch -glob -- $key \
          {
            -bg     -
            -bac*   \
            {
              #::sframe::_$w config $key $value
              $w.sframe_f config $key $value
              $w.sframe_f.f config $key $value
            }
            -col*   -
            -con*   -
            -cur*   -
            -padx   -
            -pady   { uplevel 1 $w.sframe_f config $key $value }
            -wid*   { uplevel 1 $w.sframe_h config $key $value }
            -hei*   { uplevel 1 $w.sframe_v config $key $value }
            default { uplevel 1 ::sframe::_$w config $key $value }
          }
        }
      }
    }

    # --------------
    # resize proc
    #
    # Update the scrollbars if necessary, in response to a change in either the viewing window
    # or the scrolled object.
    # Replaces the old resize and the old vresize
    # A <Configure> call may mean any change to the viewing window or the scrolled object.
    # We only need to resize the scrollbars if the size of one of these objects has changed.
    # Usually the window sizes have not changed, and so the proc will not resize the scrollbars.
    # --------------
    # parm1: widget name
    # parm2: pass anything to force resize even if dimensions are unchanged
    # --------------
    proc resize {w args} \
    {
      variable {}
      set force [llength $args]

      set _vheight     $($w:vheight)
      set _vwidth      $($w:vwidth)
      # compute new height & width
      set ($w:vheight) [winfo reqheight $w.sframe_f.f]
      set ($w:vwidth)  [winfo reqwidth  $w.sframe_f.f]

      # The size may have changed, e.g. by manual resizing of the window
      set _height     $($w:height)
      set _width      $($w:width)
      set ($w:height) [winfo height $w.sframe_f] ;# gives the actual height of the viewing window
      set ($w:width)  [winfo width  $w.sframe_f] ;# gives the actual width of the viewing window

      if {$force || $($w:vheight) != $_vheight || $($w:height) != $_height} \
      {
        # resize the vertical scroll bar
        yview $w scroll 0 unit
        yset $w
      }

      if {$force || $($w:vwidth) != $_vwidth || $($w:width) != $_width} \
      {
        # resize the horizontal scroll bar
        xview $w scroll 0 unit
        xset $w
      }
    } ;# end proc resize

    # -------------
    # xview
    #
    # called on horizontal scrolling
    # -------------
    # parm1: widget path
    # parm2: optional moveto or scroll
    # parm3: fraction if parm2 == moveto, count unit if parm2 == scroll
    # -------------
    # return: scrolling info if parm2 is empty
    # -------------
    proc xview {w {cmd ""} args} \
    {
      variable {}
      update
      # check args
      set len [llength $args]
      switch -glob -- $cmd \
      {
        ""      {set args {}}
        mov*    \
        { if {$len != 1} { error "wrong # args: should be \"$w xview moveto fraction\"" } }
        scr*    \
        { if {$len != 2} { error "wrong # args: should be \"$w xview scroll count unit\"" } }
        default \
        { error "unknown operation \"$cmd\": should be empty, moveto or scroll" }
      }
      # save old values:
      set _vleft $($w:vleft)
      set _vwidth $($w:vwidth)
      set _width  $($w:width)
      # compute new vleft
      set count ""
      switch $len \
      {
        0       \
        {
          # return fractions
          if {$_vwidth == 0} { return {0 1} }
          set first [expr {double($_vleft) / $_vwidth}]
          set last [expr {double($_vleft + $_width) / $_vwidth}]
          if {$last > 1.0} { return {0 1} }
          return [list [format %g $first] [format %g $last]]
        }
        1       \
        {
          # absolute movement
          set vleft [expr {int(double($args) * $_vwidth)}]
        }
        2       \
        {
          # relative movement
          foreach {count unit} $args break
          if {[string match p* $unit]} { set count [expr {$count * 9}] }
          set vleft [expr {$_vleft + $count * 0.1 * $_width}]
        }
      }
      if {$vleft + $_width > $_vwidth} { set vleft [expr {$_vwidth - $_width}] }
      if {$vleft < 0} { set vleft 0 }
      if {$vleft != $_vleft || $count == 0} \
      {
        set ($w:vleft) $vleft
        xset $w
        place $w.sframe_f.f -in $w.sframe_f -x [expr {-$vleft}] -width {}
      }
    }

    # -------------
    # yview
    #
    # called on vertical scrolling
    # -------------
    # parm1: widget path
    # parm2: optional moveto or scroll
    # parm3: fraction if parm2 == moveto, count unit if parm2 == scroll
    # -------------
    # return: scrolling info if parm2 is empty
    # -------------
    proc yview {w {cmd ""} args} \
    {
      puts "yview $w $cmd $args"
      variable {}
      update
      # check args
      set len [llength $args]
      switch -glob -- $cmd \
      {
        ""      {set args {}}
        mov*    \
        { if {$len != 1} { error "wrong # args: should be \"$w yview moveto fraction\"" } }
        scr*    \
        { if {$len != 2} { error "wrong # args: should be \"$w yview scroll count unit\"" } }
        default \
        { error "unknown operation \"$cmd\": should be empty, moveto or scroll" }
      }
      # save old values
      set _vtop $($w:vtop)
      set _vheight $($w:vheight)
      set _height $($w:height)
      # compute new vtop
      set count ""
      switch $len \
      {
        0       \
        {
          # return fractions
          if {$_vheight == 0} { return {0 1} }
          set first [expr {double($_vtop) / $_vheight}]
          set last [expr {double($_vtop + $_height) / $_vheight}]
          if {$last > 1.0} { return {0 1} }
          return [list [format %g $first] [format %g $last]]
        }
        1       \
        {
          # absolute movement
          set vtop [expr {int(double($args) * $_vheight)}]
        }
        2       \
        {
          # relative movement
          foreach {count unit} $args break
          if {[string match p* $unit]} { set count [expr {$count * 9}] }
          set vtop [expr {$_vtop + $count * 0.1 * $_height}]
        }
      }
      if {$vtop + $_height > $_vheight} { set vtop [expr {$_vheight - $_height}] }
      if {$vtop < 0} { set vtop 0; puts $vtop }
      if {$vtop != $_vtop || $count == 0} \
      {
        set ($w:vtop) $vtop
        yset $w
        place $w.sframe_f.f -in $w.sframe_f -y [expr {-$vtop}] -height {}
      }
    }

    # --------------
    # xset proc
    #
    # resize the visible part
    # --------------
    # parm1: widget name
    # --------------
    proc xset {w} \
    {
      variable {}
      # call the xscroll command
      catch { eval $w.sframe_hs set [xview $w] }
    }

    # --------------
    # yset proc
    #
    # resize the visible part
    # --------------
    # parm1: widget name
    # --------------
    proc yset {w} \
    {
      variable {}
      # call the yscroll command
      catch { eval $w.sframe_vs set [yview $w] }
    }

  }

  namespace import ::sframe::sframe

L'installation

Installer le package scrolled qui comprend stext, sframe et scanvas.


Le test

  package require sframe
  sframe .sf -width 100 -height 250 -bg beige
  set f [.sf frame]
  for {set i 1} {$i <= 20} {incr i} \
  {
    label $f.l$i -bg beige -text "  this widget is the scrolled label $i  "
    grid $f.l$i -column 1
  }
  pack .sf -fill both -expand 1
  .sf yview moveto 1.0

Voir aussi


Discussion


Catégorie Exemple | Catégorie paquet