scrolled.frame

GPS @ April 25 2003 - For my SDynObject project I wrote a scrolled frame widget in order to demonstrate how easy it's to use SDynObject. The code below creates this image:

SDynObject is available under the terms of a license similar to Tcl. You can download it and this demo here: http://www.xmission.com/~georgeps/SDynObject

LV 2009-Jul-14 Anyone know the current URL for SDynObject and demos ?

hae 2009-Jul-14 See http://wiki.tcl.tk/6196

for a version of the SDynObject code.

  source ./SDynObject.tcl
      
  proc scrolled.frame {win childWinPtr args} {
    upvar $childWinPtr childWin
    set obj [sd.new.object]
  
    if {[llength $args] & 1} {
      return -code error "bad number of arguments; uneven number: $args"
    }
  
    set options(-xscrollcommand) ""
    set options(-yscrollcommand) ""
    set options(-width) 200
    set options(-height) 200
  
    array set options $args
    
    foreach item [list -xscrollcommand -yscrollcommand -width -height] {
      $obj $item [set options($item)]
      unset options($item)
    }
      
    if {[array size options] > 0} {
      return -code error "invalid argument(s) to $win: [array get options]"
    }
  
    $obj didInitialConfigure 0
  
    sd.new.method update.xview.scrollbar for $obj takes args {
      uplevel #0 [$self -xscrollcommand] $args
    }
    
    sd.new.method update.yview.scrollbar for $obj takes args {
      uplevel #0 [$self -yscrollcommand]  $args
    }
    
    sd.new.method event.configure for $obj takes {win frameWin width height} {
      set halfWidth [expr {$width / 2}]
      set halfHeight [expr {$height / 2}]
      $win.c configure -scrollregion [list -$halfWidth -$halfHeight $halfWidth $halfHeight]
  
      if {0 == [$self didInitialConfigure]} {
        $win.c xview moveto 0
        $win.c yview moveto 0
        after idle [list $self didInitialConfigure 1]
      }
    }
    
    sd.new.method instance.handler for $obj takes {win args} {
      if {[llength $args] < 3} {
        return -code error "invalid number of arguments sent to $win"
      }
  
      set subCmd [lindex $args 0]
      if {"xview" == $subCmd} {
        uplevel #0 $win.c $args
      } elseif {"yview" == $subCmd} {
        uplevel #0 $win.c $args
      } else {
        return -code error "invalid subcommand sent to $win: $subCmd"
      }
    }
  
    frame $win
    
    canvas $win.c -xscrollcommand [$obj update.xview.scrollbar] \
      -yscrollcommand [$obj update.yview.scrollbar]
    
    pack $win.c -fill both -expand 1
    frame $win.c.f
    bind $win.c.f <Configure> [list [$obj event.configure] $win %W %w %h]
    $obj frameId [$win.c create window 0 0 -window $win.c.f]
    set childWin $win.c.f
  
    rename $win _orig$win
    interp alias {} $win {} [$obj instance.handler] $win
    
    return $win
  }
  
  #BEGIN DEMO
  proc add.more childWin {
    if {[winfo exists $childWin.l0]} {
      return
    }
  
    for {set i 0} {$i < 50} {incr i} {
      pack [label $childWin.l$i -text "Label $i"]
    }
  }
  
  proc main {} {
    pack [frame .fm] -fill both -expand 1
  
    scrollbar .fm.xscroll -orient horizontal -command [list .fm.sf xview]
    scrollbar .fm.yscroll -command [list .fm.sf yview]
    scrolled.frame .fm.sf childWin -xscrollcommand [list .fm.xscroll set] \
      -yscrollcommand [list .fm.yscroll set]
  
    grid .fm.xscroll -row 1 -column 0 -sticky we
    grid .fm.yscroll -row 0 -column 1 -sticky ns
    grid .fm.sf -row 0 -column 0 -sticky news
  
    grid rowconfigure .fm 0 -weight 1
    grid columnconfigure .fm 0 -weight 1
  
    for {set y 0} {$y < 40} {incr y} {
      pack [frame $childWin.f$y] -fill x
      for {set x 0} {$x < 20} {incr x} {
        pack [button $childWin.f$y.$x -text "$x $y"] -side left
      }
    }
    pack [button .b -text {Add More} -command [list add.more $childWin]]
  }
  main

See also

Category GUI

Category Widget