ulis, 2003-06-28: A hacked package to scroll a frame in pure Tcl/Tk.

----

A snapshot:

[http://perso.wanadoo.fr/maurice.ulis/tcl/ScrolledFrame/ScrolledFrame.gif]

----

The package:

  if {[info exists ::scrolledframe::version]} { return }
  namespace eval ::scrolledframe \
  {
  # beginning of ::scrolledframe namespace definition

    namespace export scrolledframe

  # ==============================
  #
  # scrolledframe
  set version 0.9
  #
  # a scrolled frame
  #
  # (C) 2003, ulis
  #
  # NOL licence (No Obligation Licence)
  #
  # ==============================
  #
  # Hacked package, no documentation, sorry
  # See example at bottom
  #
  # ==============================

    package provide Scrolledframe $version

    # --------------
    #
    # create a scrolled frame
    #
    # --------------
    # parm1: widget name
    # parm2: options key/value list
    # --------------
    proc scrolledframe {w args} \
    {
      variable {}
      # create a scrolled frame
      frame $w
      # trap the reference
      rename $w ::scrolledframe:w:$w
      # redirect to dispatch
      interp alias {} $w {} ::scrolledframe::dispatch $w
      # create scrollable internal frame
      frame $w.scrolled
      # place it
      place $w.scrolled -in $w -x 0 -y 0
      # init internal data
      set ($w:vheight) 0
      set ($w:vwidth) 0
      set ($w:vtop) 0
      set ($w:vleft) 0
      set ($w:xscroll) ""
      set ($w:yscroll) ""
      # configure
      if {$args != ""} { eval dispatch $w config $args }
      # bind <Configure>
      bind $w <Configure> [namespace code [list vresize $w]]
      bind $w.scrolled <Configure> [namespace code [list resize $w]]
      # return widget ref
      return $w
    }

    # --------------
    #
    # dispatch the trapped command
    #
    # --------------
    # parm1: widget name
    # parm2: operation
    # parm2: operation args
    # --------------
    proc dispatch {w cmd args} \
    {
      variable {}
      switch -glob -- $cmd \
      {
        con*    \
        {
          # config
          eval [linsert $args 0 config $w] 
        }
        xvi*    \
        {
          # new xview operation
          eval [linsert $args 0 xview $w] 
        }
        yvi*    \
        {
          # new yview operation
          eval [linsert $args 0 yview $w] 
        }
        default \
        { 
          # other operations
          eval [linsert $args 0 w:$w $cmd] 
        }
      }
    }

    # --------------
    # configure operation
    #
    # configure the widget
    # --------------
    # parm1: widget name
    # parm2: options
    # --------------
    proc config {w args} \
    {
      variable {}
      set options {}
      set flag 0
      foreach {key value} $args \
      {
        switch -glob -- $key \
        {
          -xsc*   \
          {
            # new xscroll option
            set ($w:xscroll) $value
            set flag 1
          }
          -ysc*   \
          {
            # new yscroll option
            set ($w:yscroll) $value
            set flag 1
          }
          default { lappend options $key $value }
        }
      }
      # check if needed
      if {!$flag || $options != ""} \
      { 
        # call frame config
        eval [linsert $options 0 ::scrolledframe:w:$w config] 
      }
    }

    # --------------
    # resize proc
    #
    # resize the scrolled part
    # --------------
    # parm1: widget name
    # --------------
    proc resize {w} \
    {
      variable {}
      # compute new height & width
      set ($w:vheight) [winfo reqheight $w.scrolled]
      set ($w:vwidth) [winfo reqwidth $w.scrolled]
      # resize the scroll bars
      vresize $w
    }

    # --------------
    # vresize proc
    #
    # resize the visible part
    # --------------
    # parm1: widget name
    # --------------
    proc vresize {w} { xset $w; yset $w }

    # --------------
    # xset proc
    #
    # resize the visible part
    # --------------
    # parm1: widget name
    # --------------
    proc xset {w} \
    {
      variable {}
      # call the xscroll command
      set cmd $($w:xscroll)
      if {$cmd != ""} { catch { eval $cmd [xview $w] } }
    }

    # --------------
    # yset proc
    #
    # resize the visible part
    # --------------
    # parm1: widget name
    # --------------
    proc yset {w} \
    {
      variable {}
      # call the yscroll command
      set cmd $($w:yscroll)
      if {$cmd != ""} { catch { eval $cmd [yview $w] } }
    }

    # -------------
    # 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 {}
      # check args
      set len [llength $args]
      switch -glob -- $cmd \
      {
        ""      {}
        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 [winfo width $w]
      # compute new vleft
      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 < 0} { set vleft 0 }
      if {$vleft + $_width > $_vwidth} { set vleft [expr {$_vwidth - $_width}] }
      if {$vleft != $_vleft} \
      {
        set ($w:vleft) $vleft
        xset $w
        place $w.scrolled -in $w -x [expr {-$vleft}]
      }
    }

    # -------------
    # 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} \
    {
      variable {}
      # check args
      set len [llength $args]
      switch -glob -- $cmd \
      {
        ""      {}
        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 [winfo height $w]
      # compute new vtop
      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 < 0} { set vtop 0 }
      if {$vtop + $_height > $_vheight} { set vtop [expr {$_vheight - $_height}] }
      if {$vtop != $_vtop} \
      {
        set ($w:vtop) $vtop
        yset $w
        place $w.scrolled -in $w -y [expr {-$vtop}]
      }
    }

  # end of ::scrolledframe namespace definition
  }

----

The demo

  # ==============================
  #
  # demo
  #
  # ==============================

    if {[catch {package require Scrolledframe}]} \
    {
      source [file join [file dirname [info script]] scrolledframe.tcl]
      package require Scrolledframe
    }
    namespace import ::scrolledframe::scrolledframe
    scrolledframe .sf -height 150 -width 100 \
        -xscroll {.hs set} -yscroll {.vs set}
    scrollbar .vs -command {.sf yview}
    scrollbar .hs -command {.sf xview} -orient horizontal
    grid .sf -row 0 -column 0 -sticky nsew
    grid .vs -row 0 -column 1 -sticky ns
    grid .hs -row 1 -column 0 -sticky ew
    grid rowconfigure . 0 -weight 1
    grid columnconfigure . 0 -weight 1
    set f .sf.scrolled
    foreach i {0 1 2 3 4 5 6 7 8 9} \
    { 
      label $f.l$i -text "Hi! I'm the scrolled label $i" -relief groove
      pack $f.l$i -padx 10 -pady 2
    }

----

See also: [Scrolled.frame]

----

[Category GUI] |
[Category Widget]