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_database