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 }