Drawer Example

Drawer Example

bll 2016-5-23. A "Drawer" is a widget that slides in and out -- a pop-open task pane (reference BOOK About Face 4th edition pp 464).

This is a simple example of an animated drawer using a paned window.

#!/usr/bin/tclsh

package require Tk

variable oldpos

proc movesash { inc limit } {
  set sp [.x.p sashpos 0]
  incr sp $inc
  if { ($inc < 0 && $sp < $limit) ||
       ($inc > 0 && $sp > $limit) } {
    set sp $limit
    .x.p sashpos 0 $sp
    return
  }
  .x.p sashpos 0 $sp
  after 15 movesash $inc $limit
}

proc doclose { w args } {
  variable oldpos

  set sp [.x.p sashpos 0]
  set oldpos $sp
  movesash -10 12
  .x.cyan.sep.c configure -text "\u27eb\n\u27eb"
  bind .x.cyan.sep <ButtonRelease-1> [list doopen %W]
  bind .x.cyan.sep.c <ButtonRelease-1> [list doopen %W]
}

proc doopen { w args } {
  variable oldpos

  movesash 10 $oldpos
  .x.cyan.sep.c configure -text "\u27ea\n\u27ea"
  bind .x.cyan.sep <ButtonRelease-1> [list doclose %W]
  bind .x.cyan.sep.c <ButtonRelease-1> [list doclose %W]
}

wm withdraw .
update
frame .x
wm manage .x

ttk::style configure TPanedwindow \
    -background lightblue
ttk::style configure Sash -sashthickness 0 \
    -handlesize 0 -handlepad 0 -sashpad 0

font create l
font configure l -size 11 -weight bold

ttk::panedwindow .x.p -orient horizontal -style TPanedwindow -height 200
pack .x.p -in .x -fill both -expand true

frame .x.cyan -background cyan -height 200 -width 50

frame .x.cyan.sep -width 12 -relief flat -background lightblue
pack .x.cyan.sep -in .x.cyan -padx 0 -pady 0 -side right -fill y -anchor e

label .x.cyan.sep.c -background lightblue -foreground darkblue \
    -text "\u27ea\n\u27ea" -font l
pack .x.cyan.sep.c -in .x.cyan.sep -fill y -expand true

ttk::button .x.cyan.a -text {Button 1}
ttk::button .x.cyan.b -text {Button 2}
ttk::button .x.cyan.c -text {Button 3}
pack .x.cyan.a .x.cyan.b .x.cyan.c -in .x.cyan -side top -anchor nw

frame .x.yellow -background yellow -height 200 -width 200

ttk::label .x.yellow.txt -text {This is frame two.}
pack .x.yellow.txt -in .x.yellow -anchor ne

.x.p add .x.cyan -weight 0
.x.p add .x.yellow -weight 1
set w [expr {[winfo reqwidth .x.cyan]+[winfo reqwidth .x.yellow]+12}]

.x.p configure -width $w
.x.p sashpos 0 [expr {[winfo reqwidth .x.cyan]+12}]

bind .x.cyan.sep <ButtonRelease-1> [list doclose %W]
bind .x.cyan.sep.c <ButtonRelease-1> [list doclose %W]
wm protocol .x WM_DELETE_WINDOW exit

JOB - 2017-12-13 16:26:08

I liked the original idea and packed the source into a "sashmanager" package. Nothing substantially new, maybe just easier to use.

WikiDBImage sashmanager.png

Here is the modified code:

  • sashmanager.tcl
# -------------------------------------------------------------------------
# sashmanager.tcl
# -------------------------------------------------------------------------
# (c) 2017, Johann Oberdorfer - Engineering Support | CAD | Software
#     johann.oberdorfer [at] googlemail.com
#     www.johann-oberdorfer.eu
# -------------------------------------------------------------------------
# This source file is distributed under the BSD license.
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#   See the BSD License for more details.
#
# Credits:
# code portions taken from: https://wiki.tcl-lang.org/44272, Drawer Example
# coded by brad.lanam.comp _at_ gmail.com
#
# A "Drawer" is a widget that slides in and out -- a pop-open task pane
# (reference BOOK About Face 4th edition pp 464).
# This is a simple example of an animated drawer using a paned window.

package provide sashmanager 0.1

namespace eval sashmanager {

        namespace export \
                sashGetPosition sashSetPosition \
                sashmanager

        variable oldpos
        variable sash_status
        variable sash_frame
        variable sash_label
        
        set sash_status 1
}


proc sashmanager::sashGetPosition {pw} {
        variable oldpos
        variable sash_frame
        variable sash_status
        
        # the following 2 lines are required,
        # so that the PageDeleteCmd will work properly ...
        set oldpos [$pw sashpos 0]
        SashDoOpen $pw $sash_frame

        return $sash_status
}

proc sashmanager::sashSetPosition {pw pos} {
        variable oldpos
        variable sash_frame

        if {![info exists pw] || ![winfo exists $pw] } { return }
        
        if {$pos == 0} {
                SashDoClose $pw $sash_frame
        } else {
                set oldpos $pos
                SashDoOpen $pw $sash_frame
        }
}


proc sashmanager::SashDoClose {pw w} {
        variable oldpos
        variable sash_frame
        variable sash_label
        variable sash_status

        if {![info exists pw] || ![winfo exists $pw] } { return }
        
        set sp [$pw sashpos 0]
        set oldpos $sp
        
        # speed changed from -40 to -80,
        # which is more reactive for big data tables...
        SashMove $pw -80 12
        
        $sash_label configure -text "\u27eb"
        bind $sash_frame <ButtonRelease-1> [list [namespace current]::SashDoOpen $pw %W]
        bind $sash_label <ButtonRelease-1> [list [namespace current]::SashDoOpen $pw %W]

        set sash_status 0
}

proc sashmanager::SashDoOpen {pw w} {
        variable oldpos
        variable sash_frame
        variable sash_label
        variable sash_status

        if {![info exists pw] || ![winfo exists $pw] } { return }
        
        SashMove $pw 40 $oldpos

        $sash_label configure -text "\u27ea"
        bind $sash_frame <ButtonRelease-1> [list [namespace current]::SashDoClose $pw %W]
        bind $sash_label <ButtonRelease-1> [list [namespace current]::SashDoClose $pw %W]

        set sash_status $oldpos
}

proc sashmanager::SashMove {pw inc limit} {

        if {![info exists pw] || ![winfo exists $pw] } { return }

        set sp [$pw sashpos 0]
        incr sp $inc
        
        if { ($inc < 0 && $sp < $limit) ||
                 ($inc > 0 && $sp > $limit) } {

                set sp $limit
                $pw sashpos 0 $sp
                return
        }
        $pw sashpos 0 $sp

        update idletasks
        
        after 10 [list [namespace current]::SashMove $pw $inc $limit]
}

proc sashmanager::sashmanager {pw frm lbl} {
        variable sash_frame
        variable sash_label

        set sash_frame $frm
        set sash_label $lbl

        $sash_label configure -text "\u27ea"
        
        bind $sash_frame <ButtonRelease-1> "[namespace current]::SashDoClose $pw %W"
        bind $sash_label <ButtonRelease-1> "[namespace current]::SashDoClose $pw %W"
}
  • sashmanager_test.tcl

Original demo code, slightly modified:

set dir [file dirname [info script]]
lappend auto_path [file join $dir "."]

package require sashmanager

# demo code:

wm withdraw .
update

frame .x
wm manage .x
wm protocol .x WM_DELETE_WINDOW exit

ttk::style configure TPanedwindow \
    -background lightblue
ttk::style configure Sash -sashthickness 0 \
    -handlesize 0 -handlepad 0 -sashpad 0

font create l
font configure l -size 11 -weight bold

set pw .x.p

ttk::panedwindow $pw -orient horizontal -style TPanedwindow -height 200
pack $pw -in .x -fill both -expand true

set frm1 .x.cyan
frame $frm1 -background cyan -height 200 -width 50

frame $frm1.sep -width 12 -relief flat -background lightblue
pack $frm1.sep -in $frm1 -padx 0 -pady 0 -side right -fill y -anchor e

ttk::button $frm1.a -text {Button 1}
ttk::button $frm1.b -text {Button 2}
ttk::button $frm1.c -text {Button 3}
pack $frm1.a $frm1.b $frm1.c -in $frm1 -side top -anchor nw

set sash_label $frm1.sep.c

label $sash_label -background lightblue -foreground darkblue -font l
pack $sash_label -in $frm1.sep -fill y -expand true

set frm2 .x.yellow
frame $frm2 -background LightGrey -height 200 -width 200

ttk::label $frm2.txt -text "This is frame two."
pack $frm2.txt -in $frm2 -anchor ne

$pw add $frm1 -weight 0
$pw add $frm2 -weight 1
set w [expr {[winfo reqwidth $frm1]+[winfo reqwidth $frm2]+12}]

$pw configure -width $w
$pw sashpos 0 [expr {[winfo reqwidth $frm1]+12}]


::sashmanager::sashmanager $pw $frm1 $sash_label
  • pkgIndex.tcl
package ifneeded sashmanager 0.1 [list source [file join $dir sashmanager.tcl]]
Category Widget
Updated 2017-12-13 16:33:37