This extension can be used to create collapsable frame. Image talks more.
http://blog.csdn.net/mzgcoco/archive/2008/11/14/3295002.aspx
download from http://cid-2c79bd952217aee4.skydrive.live.com/self.aspx/App/wrapframe.zip
HaO 2021-01-29: as both links are gone, I add the copy from my hardisk here:
wrap_frame.tcl# wrap_frame.tcl
#====================================================================
#
# Copyright (c) 2008, Zhigang,Mao
# All rights reserved.
#
# See the file LICENSE for license
#
#----------------------- Histroy ------------------------------------
#
# 11-11-08 Zhigang,Mao - Initialize version1.0
#
#----------------------- Usage --------------------------------------
#
# Please refer to the demos in the package
#
#====================================================================
package require Ttk
package provide wrapframe 1.0
namespace eval ::wrapframe {
set wf_idx 0
array set h_data [list]
set def_lbl_h 15
set def_pad 5
set def_pad1 2
set update_num 20
set def_color red4
set def_grey cyan4
set def_fnt {ansi 10}
proc wf_create_image {image_name color direction} {
image create photo $image_name -height 16 -width 16
set color $color
if [string match $direction "up"] {
for {set i 2} {$i <=7} {incr i} {
set j [expr 2 + 6 - $i]
$image_name put $color -to $i $j
$image_name put $color -to $i [expr $j + 1]
$image_name put $color -to $i [expr $j - 1]
}
for {set i 2} {$i <=7} {incr i} {
set j [expr 2 + 12 - $i]
$image_name put $color -to $i $j
$image_name put $color -to $i [expr $j - 1]
$image_name put $color -to $i [expr $j + 1]
}
for {set i 8} {$i <=13} {incr i} {
set j [expr $i - 6 - 1]
$image_name put $color -to $i $j
$image_name put $color -to $i [expr $j + 1]
$image_name put $color -to $i [expr $j - 1]
}
for {set i 8} {$i <=13} {incr i} {
set j [expr $i - 1]
$image_name put $color -to $i $j
$image_name put $color -to $i [expr $j - 1]
$image_name put $color -to $i [expr $j + 1]
}
} else {
for {set i 2} {$i <= 7} {incr i} {
set j [expr $i]
$image_name put $color -to $i $j
$image_name put $color -to $i [expr $j + 1]
$image_name put $color -to $i [expr $j - 1]
}
for {set i 2} {$i <= 7} {incr i} {
set j [expr 6 + $i]
$image_name put $color -to $i $j
$image_name put $color -to $i [expr $j - 1]
$image_name put $color -to $i [expr $j + 1]
}
for {set i 8} {$i <= 13} {incr i} {
set j [expr 15 - $i]
$image_name put $color -to $i $j
$image_name put $color -to $i [expr $j + 1]
$image_name put $color -to $i [expr $j - 1]
}
for {set i 8} {$i <= 13} {incr i} {
set j [expr 15 + 6 - $i]
$image_name put $color -to $i $j
$image_name put $color -to $i [expr $j - 1]
$image_name put $color -to $i [expr $j + 1]
}
}
}
wf_create_image up $def_color up
wf_create_image down $def_color down
wf_create_image up_grey $def_grey up
wf_create_image down_grey $def_grey down
label .test_lbl -image up -text "test" -compound right -height $def_lbl_h
set req_h [winfo reqheight .test_lbl]
destroy .test_lbl
set def_low_height [expr $req_h + 4]
proc wf_wrapframe {parent text text_side args} {
set update $wrapframe::update_num
set fnt $wrapframe::def_fnt
set mode SINGLE
foreach {opt val} $args {
if {$opt == "-speed"} {
set update $val
} elseif {$opt == "-font"} {
set fnt $val
}
}
wrapframe::wf_wrapframe_internal $parent $text $text_side -speed $update -font $fnt
}
proc wf_wrapframe_internal {parent text text_side args} {
if {$parent == "."} {
set parent ""
}
set update $wrapframe::update_num
set fnt $wrapframe::def_fnt
set mode SINGLE
foreach {opt val} $args {
if {$opt == "-speed"} {
set update $val
} elseif {$opt == "-font"} {
set fnt $val
} elseif {$opt == "-mode"} {
set mode $val
}
}
incr wrapframe::wf_idx
set wf_idx $wrapframe::wf_idx
set lbl [label $parent.lbl_$wf_idx -image up_grey -height $wrapframe::def_lbl_h]
set lf [ttk::labelframe $parent.lf_$wf_idx -labelwidget $lbl \
-labelanchor ne]
set wf [ttk::frame $lf.wf]
bind $lbl <ButtonRelease-1> \
[list wrapframe::wf_cmd_switch $lbl $lf $mode $update]
bind $lbl <Enter> [list wrapframe::wf_enter $lbl]
bind $lbl <Leave> [list wrapframe::wf_leave $lbl]
if [string match $text_side "RIGHT"] {
$lbl config -text "$text " -compound right -font $fnt
} else {
set title [label ${lf}_title -text $text -font $fnt]
set y [expr -1 * [winfo reqheight $title] / 2.0]
place $title -in $lf -y $y -relx 0.05 -anchor w
}
pack $wf -expand no -fill both -padx $wrapframe::def_pad1 \
-pady $wrapframe::def_pad1
pack $lf -expand no -fill x -padx $wrapframe::def_pad \
-pady $wrapframe::def_pad -side top -anchor n
set wrapframe::h_data($lf) [winfo reqheight $lf]
return $wf
}
proc wf_update_database {} {
set namelist [array names wrapframe::h_data]
update
foreach one $namelist {
set wrapframe::h_data($one) [winfo reqheight $one]
pack propagate $one 0
}
}
proc wf_enter {lbl} {
set img [lindex [$lbl config -image] end]
if {[string match "up" $img] || [string match "up_grey" $img]} {
$lbl config -image up
} else {
$lbl config -image down
}
}
proc wf_leave {lbl} {
set img [lindex [$lbl config -image] end]
if {[string match "up" $img] || [string match "up_grey" $img]} {
$lbl config -image up_grey
} else {
$lbl config -image down_grey
}
}
proc wf_groupframes {wgt group_name items args} {
set wf_list [list]
set update $wrapframe::update_num
set sub_fnt $wrapframe::def_fnt
set grp_fnt $wrapframe::def_fnt
foreach {opt val} $args {
if {$opt == "-speed"} {
set update $val
} elseif {$opt == "-sfont"} {
set sub_fnt $val
} elseif {$opt == "-gfont"} {
set grp_fnt $val
}
}
set group [wrapframe::wf_wrapframe_internal $wgt $group_name LEFT \
-speed $update \
-font $grp_fnt]
foreach one $items {
lappend wf_list [wrapframe::wf_wrapframe_internal $group $one LEFT \
-speed $update \
-font $sub_fnt \
-mode GROUP]
}
pack $group -fill x -padx 5 -pady 5 -side top -anchor n
return $wf_list
}
proc wf_cmd_switch {b lf mode update_num} {
set img [lindex [$b config -image] end]
set speed 0
set height $wrapframe::h_data($lf)
set width [winfo width $lf]
set speed [expr abs(($height - $wrapframe::def_low_height)/$update_num)]
set w [winfo width $lf]
#define the speed map
if {$w > 200 && $w < 400} {
set speed [expr $speed * 2]
} elseif {$w >=400 && $w < 600} {
set speed [expr $speed * 2]
} elseif {$w >=600 && $w < 800} {
set speed [expr $speed * 3]
} elseif {$w >=800 && $w < 1000} {
set speed [expr $speed * 3]
} elseif {$w >=1000 && $w < 1200} {
set speed [expr $speed * 4]
} elseif {$w >=1200} {
set speed [expr $speed * 4]
}
if [string match $mode "GROUP"] {
set grp [winfo parent [winfo parent $lf]]
pack propagate $grp 1
}
if [string match "up*" $img] {
$b config -image down
for {set i $height} {$i > $wrapframe::def_low_height} {incr i -$speed} {
$lf config -height $i -width $width
update
}
$lf config -height $wrapframe::def_low_height -width $width
} else {
$b config -image up
for {set i $wrapframe::def_low_height} {$i < $height} {incr i $speed} {
$lf config -height $i -width $width
update
}
$lf config -height $height -width $width
}
update
if [string match $mode "GROUP"] {
set reqh [winfo reqheight $grp]
set reqw [winfo reqwidth $grp]
pack propagate $grp 0
$grp config -height $reqh -width $reqw
set wrapframe::h_data($grp) $reqh
}
}
namespace export wf_wrapframe wf_groupframes wf_update_database
}
namespace import wrapframe::wf_wrapframe \
wrapframe::wf_groupframes \
wrapframe::wf_update_database
package ifneeded wrapframe 1.0 [list source [file join $dir wrap_frame.tcl]]
Copyright (c) 2008, Zhigang Mao All rights reserved.
Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
- Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
- Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
- The name of the copyright holder and any other contributors may not be used to endorse or promote products derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
lappend auto_path .
package require wrapframe
proc create_check_buttons {frm} {
set b1 [ttk::checkbutton $frm.b1 -text "button1"]
set b2 [ttk::checkbutton $frm.b2 -text "button2"]
set b3 [ttk::checkbutton $frm.b3 -text "button3"]
grid $b1 -sticky news -padx 20 -pady 5
grid $b2 -sticky news -padx 20 -pady 5
grid $b3 -sticky news -padx 20 -pady 5
grid columnconfigure $frm 0 -weight 1
}
proc create_horz_buttons {frm} {
set b1 [ttk::button $frm.b1 -text "button1"]
set b2 [ttk::button $frm.b2 -text "button2"]
set b3 [ttk::button $frm.b3 -text "button3"]
grid $b1 -sticky news -padx 20 -pady 5
grid $b2 -sticky news -padx 20 -pady 5
grid $b3 -sticky news -padx 20 -pady 5
grid columnconfigure $frm 0 -weight 1
}
frame .f
set f1 [wf_wrapframe .f Options RIGHT -font {ansi 12 }]
set f2 [wf_wrapframe .f Setting LEFT -font {ansi 12 italic}]
create_horz_buttons $f1
create_check_buttons $f2
pack .f -side top -fill x
wf_update_databaselappend auto_path .
package require wrapframe
proc create_check_buttons {frm} {
set b1 [ttk::checkbutton $frm.b1 -text "button1"]
set b2 [ttk::checkbutton $frm.b2 -text "button2"]
set b3 [ttk::checkbutton $frm.b3 -text "button3"]
grid $b1 -sticky news -padx 5 -pady 5
grid $b2 -sticky news -padx 5 -pady 5
grid $b3 -sticky news -padx 5 -pady 5
grid columnconfigure $frm 0 -weight 1
}
proc create_horz_buttons {frm} {
set b1 [ttk::button $frm.b1 -text "button1"]
set b2 [ttk::button $frm.b2 -text "button2"]
set b3 [ttk::button $frm.b3 -text "button3"]
grid $b1 -sticky news -padx 5 -pady 5
grid $b2 -sticky news -padx 5 -pady 5
grid $b3 -sticky news -padx 5 -pady 5
grid columnconfigure $frm 0 -weight 0
}
set g1 [wf_groupframes . Group1 [list Setting Options] \
-gfont {ansi 12 bold} -sfont {ansi 11 italic}]
set g2 [wf_groupframes . Group1 [list Setting Options] \
-gfont {ansi 12 bold} -sfont {ansi 11 italic}]
create_horz_buttons [lindex $g1 0]
create_check_buttons [lindex $g1 1]
set txt1 [text [lindex $g2 0].txt -bg lightyellow -width 60 -height 5]
set txt2 [text [lindex $g2 1].txt -bg lightblue -width 60 -height 3]
pack $txt1 -expand no -padx 5 -pady 5
pack $txt2 -expand no -padx 5 -pady 5
wf_update_databaseIn addition, here is the quite similar widget "CollapsableFrame.tcl" by William J Giddings. As I did not find it any more, here is the copy from my harddisk
CollapsableFrame############################################ # # CollapsableFrame.tcl # ------------------------ # # Copyright (C) 2005 William J Giddings # email: [email protected] # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 GNU # Library General Public License for more details. # # You should have received a copy of the GNU Library General Public # License along with this library; if not, write to the # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # ############################################ # # Description: # ----------- # Provide a collapsable labeled frame widget. # # Creation: # -------- # CollapsableFrame pathName ?option value...? # # Standard Options: # ---------------- # -text Text to dispay in frame. # -width Width of frame. # -borderwidth Width of displayed frame border. # -height Maximum height of the frame. # # Widget Specific Options: # ----------------------- # none # # Returns: # -------- # Pathname of the frame container. # # Widget Commands: # -------- # pathName open Open/expand frame to reveal contents. # pathName close Close/collapse frame to hide contents. # pathName toggle Flip state. # pathName getframe Returns path to the widget container. # pathName title string Set title to new value. # # Bindings: # -----------------------------------# # Arrow Button-1 Open/Close frame. # # Example: # ------- # This module includes a demo proceedure. Delete and/or comment out as required. # # Note: # ---- # Work still in progress. # As always, programming is an art. Like a painting, it is never finished. # Good programmers and artists have one critical faculty in common: knowing when to stop! # # When adding new widgets to the container, ensure that the maximum height of the # frame is sufficient to accomodate all items. # # Use the place geometry manager to explicitly position child widgets. # # Future enhancements: # ------------------- # ############################################ #!/bin/sh \ exec tclsh "$0" "$@" package require Tk package provide CollapsableFrame 1.0 namespace eval CollapsableFrame {} proc CollapsableFrame {base args} { #------- # set some defaults #------- set text $base set height 47 set width 125 set borderwidt 2 set labelheight 16 #------- # parges args #------- foreach {arg val} $args { switch -- $arg { -text - -width - -borderwidth - -height { set [string trimleft $arg -] $val} } } #------- # create button icons #------- image create photo im_Open -data R0lGODlhEAAQAKIAAP///9TQyICAgEBAQAAAAAAAAAAAAAAAACwAAAAAEAAQAAADNhi63BMgyinFAy0HC3Xj2EJoIEOM32WeaSeeqFK+say+2azUi+5ttx/QJeQIjshkcsBsOp/MBAA7 image create photo im_Close -data R0lGODlhEAAQAKIAAP///9TQyICAgEBAQAAAAAAAAAAAAAAAACwAAAAAEAAQAAADMxi63BMgyinFAy0HC3XjmLeA4ngpRKoSZoeuDLmo38mwtVvKu93rIo5gSCwWB8ikcolMAAA7 #------- # create container #------- frame $base \ -height $height \ -width $width #------- # visible frame #------- frame $base.fra1 \ -borderwidth $borderwidt \ -height $labelheight \ -relief ridge \ -width $width pack $base.fra1 \ -in $base \ -anchor center \ -expand 1 \ -fill x \ -pady 7 \ -side left #------- # toggle arrow #------- label $base.lab1 \ -borderwidth 0 \ -image im_Open \ -relief raised \ -text $height place $base.lab1 \ -x 5 \ -y -1 \ -width 21 \ -height 21 \ -anchor nw \ -bordermode ignore #------- # arrow bindings #------- bind $base.lab1 <Button-1> { set a [%W cget -image] if { $a == "im_Open" } { %W configure -image im_Close [winfo parent %W].fra1 configure -height [%W cget -text] } else { %W configure -image im_Open [winfo parent %W].fra1 configure -height 16 } } #------- # frame title #------- label $base.lab2 \ -anchor w \ -borderwidth 1 \ -text $text place $base.lab2 \ -x 23 \ -y 3 \ -height 12 \ -anchor nw \ -bordermode ignore #------- # Here comes the overloaded widget proc: #------- rename $base _$base ;# keep the original widget command proc $base {cmd args} { set self [lindex [info level 0] 0] ;# get name I was called with switch -- $cmd { open {eval CollapsableFrame::open $self $args} close {eval CollapsableFrame::close $self $args} toggle {eval CollapsableFrame::toggle $self $args} getframe {eval CollapsableFrame::getframe $self $args} default {uplevel 1 _$self $cmd $args} } } return $base.fra1 } #------- # Check the current widget state then reverse it. #------- proc CollapsableFrame::toggle {w} { set a [$w.lab1 cget -image] if { $a == "im_Open" } { $w.lab1 configure -image im_Close [winfo parent $w.lab1].fra1 configure -height [$w.lab1 cget -text] } else { $w.lab1 configure -image im_Open [winfo parent $w.lab1].fra1 configure -height 16 } } #------- # Collapse the widget, display the 'can be opened' icon. #------- proc CollapsableFrame::close {w} { $w.lab1 configure -image im_Open [winfo parent $w.lab1].fra1 configure -height 16 } #----------------------------------------------------------- # Open the widget, display the 'can be closed' icon. #----------------------------------------------------------- proc CollapsableFrame::open {w} { $w.lab1 configure -image im_Close [winfo parent $w.lab1].fra1 configure -height [$w.lab1 cget -text] } #------- # get path to display area #------- proc CollapsableFrame::getframe {w} { return $w.fra1 } #------- # demo block #------- proc demo {} { CollapsableFrame .cf1 \ -text "Frame1 " \ -height 80 pack .cf1 \ -in [winfo parent .cf1] \ -anchor center \ -expand 0 \ -fill x \ -side top CollapsableFrame .cf2 \ -text "Frame2 " \ -height 80 pack .cf2 \ -in [winfo parent .cf2] \ -anchor center \ -expand 0 \ -fill x \ -side top #------- # place child widgets inside the container #------- place [button [.cf1 getframe].but1 -text BUTTON(A,1)] -x 10 -y 15 place [button [.cf1 getframe].but2 -text BUTTON(A,2)] -x 10 -y 45 place [button [.cf2 getframe].but1 -text BUTTON(B,1)] -x 10 -y 15 place [button [.cf2 getframe].but2 -text BUTTON(B,2)] -x 10 -y 45 } demo
Jeff Smith 2021-02-01 : Below is an online demo using CloudTk. This demo runs "wrapframe" in an Alpine Linux Docker Container. It is a 27.4MB image which is made up of Alpine Linux + tclkit + wrapframe.kit + libx11 + libxft + fontconfig + ttf-linux-libertine. It is run under a user account in the Container. The Container is restrictive with permissions for "Other" removed for "execute" and "read" for certain directories.
By clicking on the "V" in the upper left corner you can access other demos.