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 bind $w [namespace code [list vresize $w]] bind $w.scrolled [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] ---- Roalt, June 30th, 2003 To use the scrolledframe without thinking about adding scrollbars, use the following wrapper to replace your "set f [frame .f]" call by a "set f [scrollframe .f]" call: ulis, 2003-06-30: When using the wrapper, be aware to only use the grid geometry manager inside the parent of the frame. This because the wrapper uses it and that geometry managers can't be mixed. ---- # function to wrap the scrolledframe package proc scrollframe { fname args } { set parent [eval frame $fname $args] scrolledframe $parent.sf \ -xscroll "$parent.hs set" -yscroll "$parent.vs set" scrollbar $parent.vs -command "$parent.sf yview" scrollbar $parent.hs -command "$parent.sf xview" -orient horizontal grid $parent.sf -row 0 -column 0 -sticky nsew grid $parent.vs -row 0 -column 1 -sticky ns grid $parent.hs -row 1 -column 0 -sticky ew grid rowconfigure $parent 0 -weight 1 grid columnconfigure $parent 0 -weight 1 return $parent.sf.scrolled } ---- [Category GUI] | [Category Widget]