00001 if {[info exists ::scrolledframe::version]} { return }
00002 namespace eval ::scrolledframe \
00003 {
00004 # beginning of ::scrolledframe namespace definition
00005
00006 package require Tk 8.4
00007 namespace export scrolledframe
00008
00009 # ==============================
00010 #
00011 # scrolledframe
00012 set version 0.9.1
00013 set (debug,place) 0
00014 #
00015 # a scrolled frame
00016 #
00017 # (C) 2003, ulis
00018 #
00019 # NOL licence (No Obligation Licence)
00020 #
00021 # Changes (C) 2004, KJN
00022 #
00023 # NOL licence (No Obligation Licence)
00024 # ==============================
00025 #
00026 # Hacked package, no documentation, sorry
00027 # See example at bottom
00028 #
00029 # ------------------------------
00030 # v 0.9.1
00031 # automatic scroll on resize
00032 # ==============================
00033
00034 package provide Scrolledframe $version
00035
00036 # --------------
00037 #
00038 # create a scrolled frame
00039 #
00040 # --------------
00041 # parm1: widget name
00042 # parm2: options key/value list
00043 # --------------
00044 proc scrolledframe {w args} \
00045 {
00046 variable {}
00047 # create a scrolled frame
00048 ttk::frame $w
00049 # trap the reference
00050 rename $w ::scrolledframe::_$w
00051 # redirect to dispatch
00052 interp alias {} $w {} ::scrolledframe::dispatch $w
00053 # create scrollable internal frame
00054 ttk::frame $w.scrolled
00055 # place it
00056 place $w.scrolled -in $w -x 0 -y 0
00057 if {$(debug,place)} { puts "place $w.scrolled -in $w -x 0 -y 0" } ;#DEBUG
00058 # init internal data
00059 set ($w:vheight) 0
00060 set ($w:vwidth) 0
00061 set ($w:vtop) 0
00062 set ($w:vleft) 0
00063 set ($w:xscroll) ""
00064 set ($w:yscroll) ""
00065 set ($w:width) 0
00066 set ($w:height) 0
00067 set ($w:fillx) 0
00068 set ($w:filly) 0
00069 # configure
00070 if {$args != ""} { uplevel 1 ::scrolledframe::config $w $args }
00071 # bind <Configure>
00072 bind $w <Configure> [namespace code [list resize $w]]
00073 bind $w.scrolled <Configure> [namespace code [list resize $w]]
00074 # return widget ref
00075 return $w
00076 }
00077
00078 # --------------
00079 #
00080 # dispatch the trapped command
00081 #
00082 # --------------
00083 # parm1: widget name
00084 # parm2: operation
00085 # parm2: operation args
00086 # --------------
00087 proc dispatch {w cmd args} \
00088 {
00089 variable {}
00090 switch -glob -- $cmd \
00091 {
00092 con* { uplevel 1 [linsert $args 0 ::scrolledframe::config $w] }
00093 xvi* { uplevel 1 [linsert $args 0 ::scrolledframe::xview $w] }
00094 yvi* { uplevel 1 [linsert $args 0 ::scrolledframe::yview $w] }
00095 default { uplevel 1 [linsert $args 0 ::scrolledframe::_$w $cmd] }
00096 }
00097 }
00098
00099 # --------------
00100 # configure operation
00101 #
00102 # configure the widget
00103 # --------------
00104 # parm1: widget name
00105 # parm2: options
00106 # --------------
00107 proc config {w args} \
00108 {
00109 variable {}
00110 set options {}
00111 set flag 0
00112 foreach {key value} $args \
00113 {
00114 switch -glob -- $key \
00115 {
00116 -fill \
00117 {
00118 # new fill option: what should the scrolled object do if it is smaller than the viewing window?
00119 if {$value == "none"} {
00120 set ($w:fillx) 0
00121 set ($w:filly) 0
00122 } elseif {$value == "x"} {
00123 set ($w:fillx) 1
00124 set ($w:filly) 0
00125 } elseif {$value == "y"} {
00126 set ($w:fillx) 0
00127 set ($w:filly) 1
00128 } elseif {$value == "both"} {
00129 set ($w:fillx) 1
00130 set ($w:filly) 1
00131 } else {
00132 error "invalid value: should be \"$w configure -fill value\", where \"value\" is \"x\", \"y\", \"none\", or \"both\""
00133 }
00134 resize $w force
00135 set flag 1
00136 }
00137 -xsc* \
00138 {
00139 # new xscroll option
00140 set ($w:xscroll) $value
00141 set flag 1
00142 }
00143 -ysc* \
00144 {
00145 # new yscroll option
00146 set ($w:yscroll) $value
00147 set flag 1
00148 }
00149 default { lappend options $key $value }
00150 }
00151 }
00152 # check if needed
00153 if {!$flag || $options != ""} \
00154 {
00155 # call frame config
00156 uplevel 1 [linsert $options 0 ::scrolledframe::_$w config]
00157 }
00158 }
00159
00160 # --------------
00161 # resize proc
00162 #
00163 # Update the scrollbars if necessary, in response to a change in either the viewing window
00164 # or the scrolled object.
00165 # Replaces the old resize and the old vresize
00166 # A <Configure> call may mean any change to the viewing window or the scrolled object.
00167 # We only need to resize the scrollbars if the size of one of these objects has changed.
00168 # Usually the window sizes have not changed, and so the proc will not resize the scrollbars.
00169 # --------------
00170 # parm1: widget name
00171 # parm2: pass anything to force resize even if dimensions are unchanged
00172 # --------------
00173 proc resize {w args} \
00174 {
00175 variable {}
00176
00177 # If the window is destroyed, do nothing
00178 if {![winfo exists $w] || ![winfo exists $w.scrolled]} {
00179 return
00180 }
00181
00182 set force [llength $args]
00183
00184 set _vheight $($w:vheight)
00185 set _vwidth $($w:vwidth)
00186 # compute new height & width
00187 set ($w:vheight) [winfo reqheight $w.scrolled]
00188 set ($w:vwidth) [winfo reqwidth $w.scrolled]
00189
00190 # The size may have changed, e.g. by manual resizing of the window
00191 set _height $($w:height)
00192 set _width $($w:width)
00193 set ($w:height) [winfo height $w] ;# gives the actual height of the viewing window
00194 set ($w:width) [winfo width $w] ;# gives the actual width of the viewing window
00195
00196 if {$force || $($w:vheight) != $_vheight || $($w:height) != $_height} {
00197 # resize the vertical scroll bar
00198 yview $w scroll 0 unit
00199 # yset $w
00200 }
00201
00202 if {$force || $($w:vwidth) != $_vwidth || $($w:width) != $_width} {
00203 # resize the horizontal scroll bar
00204 xview $w scroll 0 unit
00205 # xset $w
00206 }
00207 } ;# end proc resize
00208
00209 # --------------
00210 # xset proc
00211 #
00212 # resize the visible part
00213 # --------------
00214 # parm1: widget name
00215 # --------------
00216 proc xset {w} \
00217 {
00218 variable {}
00219 # call the xscroll command
00220 set cmd $($w:xscroll)
00221 if {$cmd != ""} { catch { eval $cmd [xview $w] } }
00222 }
00223
00224 # --------------
00225 # yset proc
00226 #
00227 # resize the visible part
00228 # --------------
00229 # parm1: widget name
00230 # --------------
00231 proc yset {w} \
00232 {
00233 variable {}
00234 # call the yscroll command
00235 set cmd $($w:yscroll)
00236 if {$cmd != ""} { catch { eval $cmd [yview $w] } }
00237 }
00238
00239 # -------------
00240 # xview
00241 #
00242 # called on horizontal scrolling
00243 # -------------
00244 # parm1: widget path
00245 # parm2: optional moveto or scroll
00246 # parm3: fraction if parm2 == moveto, count unit if parm2 == scroll
00247 # -------------
00248 # return: scrolling info if parm2 is empty
00249 # -------------
00250 proc xview {w {cmd ""} args} \
00251 {
00252 variable {}
00253 # check args
00254 set len [llength $args]
00255 switch -glob -- $cmd \
00256 {
00257 "" {set args {}}
00258 mov* \
00259 { if {$len != 1} { error "wrong # args: should be \"$w xview moveto fraction\"" } }
00260 scr* \
00261 { if {$len != 2} { error "wrong # args: should be \"$w xview scroll count unit\"" } }
00262 default \
00263 { error "unknown operation \"$cmd\": should be empty, moveto or scroll" }
00264 }
00265 # save old values:
00266 set _vleft $($w:vleft)
00267 set _vwidth $($w:vwidth)
00268 set _width $($w:width)
00269 # compute new vleft
00270 set count ""
00271 switch $len \
00272 {
00273 0 \
00274 {
00275 # return fractions
00276 if {$_vwidth == 0} { return {0 1} }
00277 set first [expr {double($_vleft) / $_vwidth}]
00278 set last [expr {double($_vleft + $_width) / $_vwidth}]
00279 if {$last > 1.0} { return {0 1} }
00280 return [list $first $last]
00281 }
00282 1 \
00283 {
00284 # absolute movement
00285 set vleft [expr {int(double($args) * $_vwidth)}]
00286 }
00287 2 \
00288 {
00289 # relative movement
00290 foreach {count unit} $args break
00291 if {[string match p* $unit]} { set count [expr {$count * 9}] }
00292 set vleft [expr {$_vleft + $count * 0.1 * $_width}]
00293 }
00294 }
00295 if {$vleft + $_width > $_vwidth} { set vleft [expr {$_vwidth - $_width}] }
00296 if {$vleft < 0} { set vleft 0 }
00297 if {$vleft != $_vleft || $count == 0} \
00298 {
00299 set ($w:vleft) $vleft
00300 xset $w
00301 if {$($w:fillx) && ($_vwidth < $_width || $($w:xscroll) == "") } {
00302 # "scrolled object" is not scrolled, because it is too small or because no scrollbar was requested
00303 # fillx means that, in these cases, we must tell the object what its width should be
00304 place $w.scrolled -in $w -x [expr {-$vleft}] -width $_width
00305 if {$(debug,place)} { puts "place $w.scrolled -in $w -x [expr {-$vleft}] -width $_width" } ;#DEBUG
00306 } else {
00307 place $w.scrolled -in $w -x [expr {-$vleft}] -width {}
00308 if {$(debug,place)} { puts "place $w.scrolled -in $w -x [expr {-$vleft}] -width {}" } ;#DEBUG
00309 }
00310
00311 }
00312 }
00313
00314 # -------------
00315 # yview
00316 #
00317 # called on vertical scrolling
00318 # -------------
00319 # parm1: widget path
00320 # parm2: optional moveto or scroll
00321 # parm3: fraction if parm2 == moveto, count unit if parm2 == scroll
00322 # -------------
00323 # return: scrolling info if parm2 is empty
00324 # -------------
00325 proc yview {w {cmd ""} args} \
00326 {
00327 variable {}
00328 # check args
00329 set len [llength $args]
00330 switch -glob -- $cmd \
00331 {
00332 "" {set args {}}
00333 mov* \
00334 { if {$len != 1} { error "wrong # args: should be \"$w yview moveto fraction\"" } }
00335 scr* \
00336 { if {$len != 2} { error "wrong # args: should be \"$w yview scroll count unit\"" } }
00337 default \
00338 { error "unknown operation \"$cmd\": should be empty, moveto or scroll" }
00339 }
00340 # save old values
00341 set _vtop $($w:vtop)
00342 set _vheight $($w:vheight)
00343 # set _height [winfo height $w]
00344 set _height $($w:height)
00345 # compute new vtop
00346 set count ""
00347 switch $len \
00348 {
00349 0 \
00350 {
00351 # return fractions
00352 if {$_vheight == 0} { return {0 1} }
00353 set first [expr {double($_vtop) / $_vheight}]
00354 set last [expr {double($_vtop + $_height) / $_vheight}]
00355 if {$last > 1.0} { return {0 1} }
00356 return [list $first $last]
00357 }
00358 1 \
00359 {
00360 # absolute movement
00361 set vtop [expr {int(double($args) * $_vheight)}]
00362 }
00363 2 \
00364 {
00365 # relative movement
00366 foreach {count unit} $args break
00367 if {[string match p* $unit]} { set count [expr {$count * 9}] }
00368 set vtop [expr {$_vtop + $count * 0.1 * $_height}]
00369 }
00370 }
00371 if {$vtop + $_height > $_vheight} { set vtop [expr {$_vheight - $_height}] }
00372 if {$vtop < 0} { set vtop 0 }
00373 if {$vtop != $_vtop || $count == 0} \
00374 {
00375 set ($w:vtop) $vtop
00376 yset $w
00377 if {$($w:filly) && ($_vheight < $_height || $($w:yscroll) == "")} {
00378 # "scrolled object" is not scrolled, because it is too small or because no scrollbar was requested
00379 # filly means that, in these cases, we must tell the object what its height should be
00380 place $w.scrolled -in $w -y [expr {-$vtop}] -height $_height
00381 if {$(debug,place)} { puts "place $w.scrolled -in $w -y [expr {-$vtop}] -height $_height" } ;#DEBUG
00382 } else {
00383 place $w.scrolled -in $w -y [expr {-$vtop}] -height {}
00384 if {$(debug,place)} { puts "place $w.scrolled -in $w -y [expr {-$vtop}] -height {}" } ;#DEBUG
00385 }
00386 }
00387 }
00388
00389 # end of ::scrolledframe namespace definition
00390 }
