[ulis], 2003-06-28: A hacked package to scroll a frame in pure Tcl/Tk. 2003-11-07, v 0.9.1: automatic scroll on resize. [ulis], 24-10-2005: see at the bottom the [KJN] optimized & enhanced version. [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.1 # # a scrolled frame # # (C) 2003, ulis # # NOL licence (No Obligation Licence) # # ============================== # # Hacked package, no documentation, sorry # See example at bottom # # ------------------------------ # v 0.9.1 # automatic scroll on resize # ============================== 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 # redirect to dispatch interp alias {} $w {} ::scrolledframe::dispatch $w # create scrollable internal frame frame $w.scrolled -highlightt 0 -padx 0 -pady 0 # 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 != ""} { uplevel 1 ::scrolledframe::config $w $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* { uplevel 1 [linsert $args 0 ::scrolledframe::config $w] } xvi* { uplevel 1 [linsert $args 0 ::scrolledframe::xview $w] } yvi* { uplevel 1 [linsert $args 0 ::scrolledframe::yview $w] } default { uplevel 1 [linsert $args 0 ::scrolledframe::_$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 uplevel 1 [linsert $options 0 ::scrolledframe::_$w config] } } # -------------- # resize proc # # resize the scrolled region # -------------- # 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} \ { xview $w scroll 0 unit yview $w scroll 0 unit 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 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 < 0} { set vleft 0 } if {$vleft + $_width > $_vwidth} { set vleft [expr {$_vwidth - $_width}] } if {$vleft != $_vleft || $count == 0} \ { 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 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 < 0} { set vtop 0 } if {$vtop + $_height > $_vheight} { set vtop [expr {$_vheight - $_height}] } if {$vtop != $_vtop || $count == 0} \ { set ($w:vtop) $vtop yset $w place $w.scrolled -in $w -y [expr {-$vtop}] puts "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 } ---- '''Another demo''' # packages source ../Scrolledframe/scrolledframe.tcl namespace import ::scrolledframe::scrolledframe package require Tk # create widgets set bd 2 set bd2 [expr {$bd * 2}] frame .f0 -bd 1 -relief groove frame .f1 button .f1._A4 -text A4 -width 10 -command {size A4} button .f1._A3 -text A3 -width 10 -command {size A3} pack .f1._A4 .f1._A3 -padx 10 -pady 10 -side left scrolledframe .f2 -xscrollc {.hs set} -yscrollc {.vs set} canvas .f2.scrolled.c -bd 1 -relief ridge \ -highlightt 0 -bg beige .f2.scrolled.c create text 0 0 -tags size pack .f2.scrolled.c scrollbar .vs -command {.f2 yview} scrollbar .hs -command {.f2 xview} -orient horizontal # place widgets grid .f0 -row 1 -column 0 -sticky nsew grid .f1 -row 0 -column 0 -columnspan 2 grid .f2 -row 1 -column 0 grid .vs -row 1 -column 1 -sticky ns grid .hs -row 2 -column 0 -sticky ew grid rowconfigure . 1 -weight 1 grid columnconfigure . 0 -weight 1 wm geometry . 300x400 # sizing the canvas proc size {size} \ { switch $size \ { A3 { set width 297; set height 420 } A4 { set width 210; set height 297 } } set c .f2.scrolled.c $c config -width $width -height $height set bd [$c cget -bd] set bd*2 [expr {$bd * 2}] .f2 config -width [incr width ${bd*2}] -height [incr height ${bd*2}] $c coords size [expr {$width / 2}] [expr {$height / 2}] $c itemconfig size -text $size } # init size A4 ---- '''See also''' * [Scrolled.frame] * [scrolledframe] ---- 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 } ---- A fully wrapped example that also passes the arguments to the scrolled internal frame. proc Scrolled_Frame { fname args } { set parent [eval frame $fname $args] scrolledframe $parent.sf -xscroll [list $parent.hs set] -yscroll [list $parent.vs set] foreach {arg1 arg2} $args { $parent.sf.scrolled configure $arg1 $arg2 } scrollbar $parent.vs -command [list $parent.sf yview] -orient vertical scrollbar $parent.hs -command [list $parent.sf xview] -orient horizontal grid $parent.sf -row 0 -column 0 -sticky news 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 } set blah [Scrolled_Frame .sf -bg #ffffff -relief sunken -bd 50] set blah2 [Scrolled_Frame .sf2] set blah3 [Scrolled_Frame .sf3 -bg #666666 -relief groove -bd 2] set x 0 while {$x < 100} { label $blah.$x -text "This is a Scrolled Frame." grid $blah.$x -row $x -column $x -sticky news label $blah2.$x -text "This is also a Scrolled Frame." grid $blah2.$x -row $x -column $x -sticky news label $blah3.$x -text "You guessed it." grid $blah3.$x -row $x -column $x -sticky news incr x } pack .sf -fill both -expand true pack .sf2 -fill both -expand true pack .sf3 -fill both -expand true ---- '''The KJN optimized & enhanced version''' if {[info exists ::scrolledframe::version]} { return } namespace eval ::scrolledframe \ { # beginning of ::scrolledframe namespace definition namespace export scrolledframe # ============================== # # scrolledframe set version 0.9.1 set (debug,place) 0 # # a scrolled frame # # (C) 2003, ulis # # NOL licence (No Obligation Licence) # # Changes (C) 2004, KJN # # NOL licence (No Obligation Licence) # ============================== # # Hacked package, no documentation, sorry # See example at bottom # # ------------------------------ # v 0.9.1 # automatic scroll on resize # ============================== 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 # redirect to dispatch interp alias {} $w {} ::scrolledframe::dispatch $w # create scrollable internal frame frame $w.scrolled -highlightt 0 -padx 0 -pady 0 # place it place $w.scrolled -in $w -x 0 -y 0 if {$(debug,place)} { puts "place $w.scrolled -in $w -x 0 -y 0" } ;#DEBUG # 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) "" set ($w:width) 0 set ($w:height) 0 set ($w:fillx) 0 set ($w:filly) 0 # configure if {$args != ""} { uplevel 1 ::scrolledframe::config $w $args } # bind bind $w [namespace code [list resize $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* { uplevel 1 [linsert $args 0 ::scrolledframe::config $w] } xvi* { uplevel 1 [linsert $args 0 ::scrolledframe::xview $w] } yvi* { uplevel 1 [linsert $args 0 ::scrolledframe::yview $w] } default { uplevel 1 [linsert $args 0 ::scrolledframe::_$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 \ { -fill \ { # new fill option: what should the scrolled object do if it is smaller than the viewing window? if {$value == "none"} { set ($w:fillx) 0 set ($w:filly) 0 } elseif {$value == "x"} { set ($w:fillx) 1 set ($w:filly) 0 } elseif {$value == "y"} { set ($w:fillx) 0 set ($w:filly) 1 } elseif {$value == "both"} { set ($w:fillx) 1 set ($w:filly) 1 } else { error "invalid value: should be \"$w configure -fill value\", where \"value\" is \"x\", \"y\", \"none\", or \"both\"" } resize $w force set flag 1 } -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 uplevel 1 [linsert $options 0 ::scrolledframe::_$w config] } } # -------------- # 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 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.scrolled] set ($w:vwidth) [winfo reqwidth $w.scrolled] # 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] ;# gives the actual height of the viewing window set ($w:width) [winfo width $w] ;# 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 # -------------- # 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 \ { "" {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 if {$($w:fillx) && ($_vwidth < $_width || $($w:xscroll) == "") } { # "scrolled object" is not scrolled, because it is too small or because no scrollbar was requested # fillx means that, in these cases, we must tell the object what its width should be place $w.scrolled -in $w -x [expr {-$vleft}] -width $_width if {$(debug,place)} { puts "place $w.scrolled -in $w -x [expr {-$vleft}] -width $_width" } ;#DEBUG } else { place $w.scrolled -in $w -x [expr {-$vleft}] -width {} if {$(debug,place)} { puts "place $w.scrolled -in $w -x [expr {-$vleft}] -width {}" } ;#DEBUG } } } # ------------- # 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 \ { "" {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 [winfo height $w] 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 } if {$vtop != $_vtop || $count == 0} \ { set ($w:vtop) $vtop yset $w if {$($w:filly) && ($_vheight < $_height || $($w:yscroll) == "")} { # "scrolled object" is not scrolled, because it is too small or because no scrollbar was requested # filly means that, in these cases, we must tell the object what its height should be place $w.scrolled -in $w -y [expr {-$vtop}] -height $_height if {$(debug,place)} { puts "place $w.scrolled -in $w -y [expr {-$vtop}] -height $_height" } ;#DEBUG } else { place $w.scrolled -in $w -y [expr {-$vtop}] -height {} if {$(debug,place)} { puts "place $w.scrolled -in $w -y [expr {-$vtop}] -height {}" } ;#DEBUG } } } # end of ::scrolledframe namespace definition } ---- '''The KJN demo''' # ============================== # # demo # # ============================== if {[catch {package require Scrolledframe}]} \ { source [file join [file dirname [info script]] sf9223.2.tcl] package require Scrolledframe } namespace import ::scrolledframe::scrolledframe scrolledframe .sf -height 150 -width 100 \ -xscrollcommand {.hs set} -yscrollcommand {.vs set} -fill both ;# try both, x, y or none 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 # .sf configure -bg white 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 -anchor nw -fill x } label $f.lf -text "Hi! I take up the slack!" -relief groove pack $f.lf -in $f -padx 10 -pady 2 -anchor nw -fill both -expand 1 ---- So, how about some examples of using the above package and proc? For instance, above, under the screenshot, how about showing the code which created it? [ulis]: see '''The demo''' & '''Another demo''' Will this code be going into [tklib]? ---- [Category Example] | [Category GUI] | [Category Widget]