[mzgcoco]

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:

<<discussion>> 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

======
<<enddiscussion>>

<<discussion>> pkgIndex.tcl

======
package ifneeded wrapframe 1.0  [list source [file join $dir wrap_frame.tcl]]
======

<<enddiscussion>>

<<discussion>> LICENCE
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.
<<enddiscussion>>

<<discussion>> demo1.tcl

======
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_database
======

<<enddiscussion>>

<<discussion>> demo2.tcl
======
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 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
======

<<enddiscussion>>

-----


**CollapsableFrame**

In 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

<<discussion>> CollapsableFrame

======
 ############################################
 #
 # CollapsableFrame.tcl
 # ------------------------
 #
 # Copyright (C) 2005 William J Giddings
 # email: giddings@freeuk.com
 #
 # 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
======

<<enddiscussion>>

----
[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.

<<inlinehtml>>

<iframe height="600" width="400" src="https://cloudtk.tcl-lang.org/cloudtk/VNC?session=new&Tk=wrapframe" allowfullscreen></iframe>

<<inlinehtml>>

----

<<categories>> Widget | GUI