Posted to tcl by emiliano at Wed Nov 17 21:42:08 GMT 2010view raw

  1. # needed only to move the original command
  2. namespace eval ::ttk::scrollableframe {}
  3. proc ::ttk::scrollableframe {w args} {
  4. frame $w -class TScrolledframe
  5. set c [canvas $w.canvas \
  6. -borderwidth 0 \
  7. -highlightthickness 0 \
  8. -background [style lookup "." -background]]
  9. pack $c -expand 1 -fill both
  10. set f [frame $w.canvas.frame]
  11. $c create window {0 0} -window $f -anchor nw
  12. bind $c <<ThemeChanged>> {
  13. %W configure -background [ttk::style lookup . -background]
  14. }
  15. bind $f <Configure> [list $c configure -scrollregion {0 0 %w %h}]
  16. bind $c <Destroy> [list rename ::$w {}]
  17.  
  18. set opts {
  19. -xscrollcommand
  20. -yscrollcommand
  21. -xscrollincrement
  22. -yscrollincrement
  23. }
  24.  
  25. dict set map getframe [list ::apply {{f} {return $f}} $f]
  26. dict set map xview [list ::apply {{c args} {$c xview {*}$args}} $c]
  27. dict set map yview [list ::apply {{c args} {$c yview {*}$args}} $c]
  28. dict set map cget [list ::apply {{c opts option} {
  29. if {$option ni $opts} {
  30. return -code error "unknown option \"$option\""
  31. }
  32. $c cget $option
  33. }} $c $opts]
  34. dict set map configure [list ::apply {{c opts args} {
  35. switch -- [llength $args] {
  36. 0 {
  37. set result [list]
  38. set conflist [$c configure]
  39. foreach option $opts {
  40. lappend result [lsearch -inline $conflist ${option}*]
  41. }
  42. return $result
  43. }
  44. 1 {
  45. set option [lindex $args 0]
  46. if {$option in $opts} {
  47. return [$c configure $option]
  48. } else {
  49. return -code error "unknown option \"$option\""
  50. }
  51. }
  52. default {
  53. dict for {option value} $args {
  54. if {$option in $opts} {
  55. $c configure $option $value
  56. } else {
  57. return -code error "unknown option \"$option\""
  58. }
  59. }
  60. }
  61. }
  62. }} $c $opts]
  63. dict set map see [list ::apply {{c widget {vert top} {horz left}} {
  64. scan [winfo geometry $widget] "%dx%d+%d+%d" w h xo yo
  65. lassign [$c cget -scrollregion] -> -> Xo Yo
  66. if {$vert eq "bottom"} {
  67. set yo [expr {$yo - [winfo height $c] + $h}]
  68. }
  69. if {$horz eq "right"} {
  70. set xo [expr {$xo - [winfo width $c] + $w}]
  71. }
  72. set yfrac [expr {double($yo) / $Yo}]
  73. set xfrac [expr {double($xo) / $Xo}]
  74. $c xview moveto $xfrac
  75. $c yview moveto $yfrac
  76. }} $c]
  77.  
  78. rename ::$w ::ttk::scrolledframe::$w
  79. namespace ensemble create \
  80. -command ::$w \
  81. -map $map
  82. ::$w configure {*}$args
  83. return $w
  84. }
  85.  
  86. # needed only to move the original command
  87. namespace eval ::ttk::scrolledwindow {}
  88. proc ::ttk::scrolledwindow {w} {
  89. frame $w -class TScrolledwindow
  90. scrollbar $w.sy -orient vertical
  91. scrollbar $w.sx -orient horizontal
  92. grid $w.sy -row 0 -column 1 -sticky ns
  93. grid $w.sx -row 1 -column 0 -sticky ew
  94. grid columnconfigure $w 0 -weight 1
  95. grid rowconfigure $w 0 -weight 1
  96. grid remove $w.sx $w.sy
  97. bind $w.sy <Destroy> [list rename ::$w {}]
  98.  
  99. set lambdaterm {{scrollbar from to} {
  100. if {$from == 0.0 && $to == 1.0} {
  101. grid remove $scrollbar
  102. } else {
  103. grid $scrollbar
  104. }
  105. $scrollbar set $from $to
  106. }}
  107.  
  108. dict set map setwidget [list ::apply {{w lambdaterm widget} {
  109. set old [grid slaves $w -row 0 -column 0]
  110. if {$old ne ""} {
  111. grid forget $old
  112. }
  113. grid $widget -in $w -sticky news -row 0 -column 0
  114. $widget configure \
  115. -xscrollcommand [list apply $lambdaterm $w.sx] \
  116. -yscrollcommand [list apply $lambdaterm $w.sy]
  117. $w.sx configure -command [list $widget xview]
  118. $w.sy configure -command [list $widget yview]
  119. }} $w $lambdaterm]
  120.  
  121. rename ::$w ::ttk::scrolledwindow::$w
  122. namespace ensemble create \
  123. -command ::$w \
  124. -map $map
  125.  
  126. return $w
  127. }
  128.