Tk Source Code

Artifact be87306428b9a08af34fea7e3836a3393ac1c514:

Attachment "scrolledframe.tcl" to ticket [2863003f] added by emiliano 2016-09-22 13:40:21. (unpublished)

---

package require Tcl 8.5
package require Tk 8.5

###########################################################################
# anonymous command prefix, executed in the current namespace
proc lambda {arglist body args} {
    set ns [uplevel 1 namespace current]
    return [list ::apply [list $arglist $body $ns] {*}$args]
}

###########################################################################
# scrollableframe implementation (ttk)
# modeled after bwidget's ScrollableFrame
namespace eval ::ttk::scrollableframe {
    bind TScrollableframe <Destroy> {rename ::%W {}}
}
proc ::ttk::scrollableframe {w args} {
    frame $w -class TScrollableframe
    set c [::canvas $w.canvas \
        -borderwidth 0 \
        -highlightthickness 0 \
        -background [ttk::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 $f <Configure> [list $c configure -scrollregion {0 0 %w %h}]
    bind $f <<GeometryManager>> [lambda {c f} {
        # adjust canvas view
        $c xview moveto 0
        $c yview moveto 0
        # resize the frame *twice*, so it end up with the same configured
        # and requested size of a newly created frame
        $f configure -width 1 -height 1
        $f configure -width 0 -height 0
    } $c $f]
    bind $c <<ThemeChanged>> {
        # this won't work with all themes, but is better than nothing
        %W configure -background [ttk::style lookup . -background]
    }

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

    dict set map getframe  [lambda {f} {return $f} $f]
    dict set map xview     [lambda {c args} {$c xview {*}$args} $c]
    dict set map yview     [lambda {c args} {$c yview {*}$args} $c]
    dict set map cget      [lambda {c opts option} {
        if {$option ni $opts} {
            return -code error "unknown option \"$option\""
        }
        return [$c cget $option]
    } $c $opts]
    dict set map configure [lambda {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 [lambda {c widget {vert top} {horz left}} {
        # the widget must be child of the canvas!
        if {![string match ${c}* $widget]} {
            return
        }
        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}]
        }
        $c xview moveto [expr {double($xo) / $Xo}]
        $c yview moveto [expr {double($yo) / $Yo}]
    } $c]

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

###########################################################################
# scrolledwindow implementation (ttk)
# modeled after bwidget's ScrolledWindow
namespace eval ::ttk::scrolledwindow {
    bind TScrolledwindow <Destroy> {rename ::%W {}}
}
proc ::ttk::scrolledwindow {w} {
    frame $w -class TScrolledwindow
    scrollbar $w.vscroll -orient vertical
    scrollbar $w.hscroll -orient horizontal
    grid $w.vscroll -row 1 -column 2 -sticky ns
    grid $w.hscroll -row 2 -column 1 -sticky ew
    grid columnconfigure $w 1 -weight 1
    grid rowconfigure    $w 1 -weight 1
    grid remove $w.vscroll $w.hscroll

    set scrlambda [lambda {scrollbar from to} {
        if {$from == 0.0 && $to == 1.0} {
            grid remove $scrollbar
        } else {
            grid $scrollbar
        }
        $scrollbar set $from $to
    }]

    dict set map setwidget [lambda {w scrlambda widget} {
        set old [grid slaves $w -row 1 -column 1]
        if {$old eq $widget} {
            return
        }
        if {$old ne ""} {
            grid forget $old
        }
        grid $widget -in $w -sticky news -row 1 -column 1
        $widget configure \
            -yscrollcommand [linsert $scrlambda end $w.vscroll] \
            -xscrollcommand [linsert $scrlambda end $w.hscroll]
        $w.vscroll configure -command [list $widget yview]
        $w.hscroll configure -command [list $widget xview]
    } $w $scrlambda]

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

    return $w
}

# demo code

if {$argv0 eq [info script]} {
    ttk::scrolledwindow .sw
    ttk::scrollableframe .sw.sf
    .sw setwidget .sw.sf

    set f [.sw.sf getframe]
    for {set i 0} {$i < 20} {incr i} {
        ttk::label $f.l1$i -text "this is a label numbered $i"
        ttk::label $f.l2$i -text "this is another label numbered $i"
        grid $f.l1$i $f.l2$i
    }
    pack .sw
    after 5000 "destroy {*}\[winfo children $f\]"
}