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

# needed only to move the original command
namespace eval ::ttk::scrollableframe {}
proc ::ttk::scrollableframe {w args} {
    frame $w -class TScrolledframe
    set c [canvas $w.canvas \
        -borderwidth 0 \
        -highlightthickness 0 \
        -background [style lookup "." -background]]
    pack $c -expand 1 -fill both
    set f [frame $w.canvas.frame]
    $c create window {0 0} -window $f -anchor nw
    bind $c <<ThemeChanged>> {
        %W configure -background [ttk::style lookup . -background]
    }
    bind $f <Configure> [list $c configure -scrollregion {0 0 %w %h}]
    bind $c <Destroy>   [list rename ::$w {}]

    set opts {
        -xscrollcommand
        -yscrollcommand
        -xscrollincrement
        -yscrollincrement
    }

    dict set map getframe  [list ::apply {{f} {return $f}} $f]
    dict set map xview     [list ::apply {{c args} {$c xview {*}$args}} $c]
    dict set map yview     [list ::apply {{c args} {$c yview {*}$args}} $c]
    dict set map cget      [list ::apply {{c opts option} {
        if {$option ni $opts} {
            return -code error "unknown option \"$option\""
        }
        $c cget $option
    }} $c $opts]
    dict set map configure [list ::apply {{c opts args} {
        switch -- [llength $args] {
            0 {
                set result [list]
                set conflist [$c configure]
                foreach option $opts {
                    lappend result [lsearch -inline $conflist ${option}*]
                }
                return $result
            }
            1 {
                set option [lindex $args 0]
                if {$option in $opts} {
                    return [$c configure $option]
                } else {
                    return -code error "unknown option \"$option\""
                }
            }
            default {
                dict for {option value} $args {
                    if {$option in $opts} {
                        $c configure $option $value
                    } else {
                        return -code error "unknown option \"$option\""
                    }
                }
            }
        }
    }} $c $opts]
    dict set map see [list ::apply {{c widget {vert top} {horz left}} {
        scan [winfo geometry $widget] "%dx%d+%d+%d" w h xo yo
        lassign [$c cget -scrollregion] -> -> Xo Yo
        if {$vert eq "bottom"} {
            set yo [expr {$yo - [winfo height $c] + $h}]
        }
        if {$horz eq "right"} {
            set xo [expr {$xo - [winfo width  $c] + $w}]
        }
        set yfrac [expr {double($yo) / $Yo}]
        set xfrac [expr {double($xo) / $Xo}]
        $c xview moveto $xfrac
        $c yview moveto $yfrac
    }} $c]

    rename ::$w ::ttk::scrolledframe::$w
    namespace ensemble create \
        -command ::$w \
        -map $map
    ::$w configure {*}$args
    return $w
}

# needed only to move the original command
namespace eval ::ttk::scrolledwindow {}
proc ::ttk::scrolledwindow {w} {
    frame $w -class TScrolledwindow
    scrollbar $w.sy -orient vertical
    scrollbar $w.sx -orient horizontal
    grid $w.sy -row 0 -column 1 -sticky ns
    grid $w.sx -row 1 -column 0 -sticky ew
    grid columnconfigure $w 0 -weight 1
    grid rowconfigure    $w 0 -weight 1
    grid remove $w.sx $w.sy
    bind $w.sy <Destroy> [list rename ::$w {}]

    set lambdaterm {{scrollbar from to} {
        if {$from == 0.0 && $to == 1.0} {
            grid remove $scrollbar
        } else {
            grid $scrollbar
        }
        $scrollbar set $from $to
    }}

    dict set map setwidget [list ::apply {{w lambdaterm widget} {
        set old [grid slaves $w -row 0 -column 0]
        if {$old ne ""} {
            grid forget $old
        }
        grid $widget -in $w -sticky news -row 0 -column 0
        $widget configure \
            -xscrollcommand [list apply $lambdaterm $w.sx] \
            -yscrollcommand [list apply $lambdaterm $w.sy]
        $w.sx configure -command [list $widget xview]
        $w.sy configure -command [list $widget yview]
    }} $w $lambdaterm]

    rename ::$w ::ttk::scrolledwindow::$w
    namespace ensemble create \
        -command ::$w \
        -map $map

    return $w
}