Posted to tcl by zipguy at Sun May 18 21:37:19 GMT 2014view raw

  1. ############################################
  2. #
  3. # CollapsableFrame.tcl
  4. # ------------------------
  5. #
  6. # Copyright (C) 2005 William J Giddings
  7. # email: giddings@freeuk.com
  8. #
  9. # This library is free software; you can redistribute it and/or
  10. # modify it under the terms of the GNU Library General Public
  11. # License as published by the Free Software Foundation; either
  12. # version 2 of the License, or (at your option) any later version.
  13. #
  14. # This library is distributed in the hope that it will be useful,
  15. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  17. # Library General Public License for more details.
  18. #
  19. # You should have received a copy of the GNU Library General Public
  20. # License along with this library; if not, write to the
  21. # Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22. # Boston, MA 02111-1307, USA.
  23. #
  24. ############################################
  25. #
  26. # Description:
  27. # -----------
  28. # Provide a collapsable labeled frame widget.
  29. #
  30. # Creation:
  31. # --------
  32. # CollapsableFrame pathName ?option value...?
  33. #
  34. # Standard Options:
  35. # ----------------
  36. # -text Text to dispay in frame.
  37. # -width Width of frame.
  38. # -borderwidth Width of displayed frame border.
  39. # -height Maximum height of the frame.
  40. #
  41. # Widget Specific Options:
  42. # -----------------------
  43. # none
  44. #
  45. # Returns:
  46. # --------
  47. # Pathname of the frame container.
  48. #
  49. # Widget Commands:
  50. # --------
  51. # pathName open Open/expand frame to reveal contents.
  52. # pathName close Close/collapse frame to hide contents.
  53. # pathName toggle Flip state.
  54. # pathName getframe Returns path to the widget container.
  55. # pathName title string Set title to new value.
  56. #
  57. # Bindings:
  58. # -----------------------------------#
  59. # Arrow Button-1 Open/Close frame.
  60. #
  61. # Example:
  62. # -------
  63. # This module includes a demo proceedure. Delete and/or comment out as required.
  64. #
  65. # Note:
  66. # ----
  67. # Work still in progress.
  68. # As always, programming is an art. Like a painting, it is never finished.
  69. # Good programmers and artists have one critical faculty in common:
  70. # knowing when to stop!
  71. #
  72. # When adding new widgets to the container, ensure that the maximum height of the
  73. # frame is sufficient to accomodate all items.
  74. #
  75. # Use the place geometry manager to explicitly position child widgets.
  76. #
  77. # Future enhancements:
  78. # -------------------
  79. #
  80. ############################################
  81.  
  82. #!/bin/sh \
  83. #exec tclsh "$0" "$@"
  84.  
  85. package require Tk
  86. package provide CollapsableFrame 1.0
  87. namespace eval CollapsableFrame {}
  88. proc CollapsableFrame {base args} {
  89. #-------
  90. # set some defaults
  91. #-------
  92. set text $base
  93. set height 147
  94. set width 125
  95. set borderwidt 2
  96. set labelheight 16
  97. #-------
  98. # parges args
  99. #-------
  100. foreach {arg val} $args {
  101. switch -- $arg {
  102. -text -
  103. -width -
  104. -borderwidth -
  105. -height { set [string trimleft $arg -] $val}
  106. }
  107. }
  108. #-------
  109. # create button icons
  110. # zipguy - both of the images im_Open im_Close replaced with better ones
  111. #-------
  112. image create photo frameds -data {R0lGODlhEQAKAPcAAAQChISChPTy9Pz+/AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAAAAAAALAAAAAARAAoABwgrAAEIHEiwoEABBhMeFIBQIUGGEB0uhMjQIcWLCS9qLKix48COIAGAHAkyIAA7}
  113. image create photo frameus -data {R0lGODlhEQAKAPcAAAQChISChPTy9Pz+/AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAAAAAAALAAAAAARAAoABwgqAAUIHEiwoEGCAA4qBMBQYUGGEB0KhEjRIcWLBy9qfKhx48SOHQWAHBkQADs=}
  114. #-------
  115. # create container
  116. #-------
  117. frame $base \
  118. -height $height \
  119. -width $width
  120. #-------
  121. # visible frame
  122. #-------
  123. frame $base.fra1 \
  124. -borderwidth $borderwidt \
  125. -height $labelheight \
  126. -relief groove \
  127. -width $width
  128. pack $base.fra1 \
  129. -in $base \
  130. -anchor center \
  131. -expand 1 \
  132. -fill x \
  133. -pady 7 \
  134. -side left
  135. #-------
  136. # toggle arrow
  137. #-------
  138. label $base.lab1 \
  139. -borderwidth 0 \
  140. -image frameds \
  141. -relief groove \
  142. -text $height
  143. place $base.lab1 \
  144. -x 5 \
  145. -y -1 \
  146. -width 21 \
  147. -height 21 \
  148. -anchor nw \
  149. -bordermode ignore
  150. #-------
  151. # arrow bindings
  152. #-------
  153. bind $base.lab1 <Button-1> {
  154. set a [%W cget -image]
  155. if { $a == "frameds" } {
  156. %W configure -image frameus
  157. [winfo parent %W].fra1 configure -height [%W cget -text]
  158. } else {
  159. %W configure -image frameds
  160. [winfo parent %W].fra1 configure -height 16
  161. }
  162. }
  163. #-------
  164. # frame title
  165. #-------
  166. label $base.lab2 \
  167. -anchor w \
  168. -borderwidth 1 \
  169. -text $text
  170. place $base.lab2 \
  171. -x 23 \
  172. -y 3 \
  173. -height 12 \
  174. -anchor nw \
  175. -bordermode ignore
  176. #-------
  177. # Here comes the overloaded widget proc:
  178. #-------
  179. rename $base _$base ;# keep the original widget command
  180. proc $base {cmd args} {
  181. set self [lindex [info level 0] 0] ;# get name I was called with
  182. switch -- $cmd {
  183. open {eval CollapsableFrame::open $self $args}
  184. close {eval CollapsableFrame::close $self $args}
  185. toggle {eval CollapsableFrame::toggle $self $args}
  186. getframe {eval CollapsableFrame::getframe $self $args}
  187. default {uplevel 1 _$self $cmd $args}
  188. }
  189. }
  190. return $base.fra1
  191. }
  192. #-------
  193. # Check the current widget state then reverse it.
  194. #-------
  195. proc CollapsableFrame::toggle {w} {
  196. set a [$w.lab1 cget -image]
  197. if { $a == "frameds" } {
  198. $w.lab1 configure -image frameus
  199. [winfo parent $w.lab1].fra1 configure -height [$w.lab1 cget -text]
  200. } else {
  201. $w.lab1 configure -image frameds
  202. [winfo parent $w.lab1].fra1 configure -height 16
  203. }
  204. }
  205. #-------
  206. # Collapse the widget, display the 'can be opened' icon.
  207. #-------
  208. proc CollapsableFrame::close {w} {
  209. $w.lab1 configure -image im_Open
  210. [winfo parent $w.lab1].fra1 configure -height 16
  211. }
  212. #-----------------------------------------------------------
  213. # Open the widget, display the 'can be closed' icon.
  214. #-----------------------------------------------------------
  215. proc CollapsableFrame::open {w} {
  216. $w.lab1 configure -image im_Close
  217. [winfo parent $w.lab1].fra1 configure -height [$w.lab1 cget -text]
  218. }
  219. #-------
  220. # get path to display area
  221. #-------
  222. proc CollapsableFrame::getframe {w} {
  223. return $w.fra1
  224. }
  225.  
  226. #-------
  227. # demo block
  228. #-------
  229. proc demo {} {
  230. # create the main window menus
  231. menu .menu -tearoff 0
  232.  
  233. # add the "file" menu
  234. set m .menu.file
  235. menu $m -tearoff 0
  236. $m add command -label "Exit " -underline 1 -command "exit"\
  237. -accelerator Ctrl+X
  238. . configure -menu .menu
  239. CollapsableFrame .cf1 \
  240. -text "Frame1 " \
  241. -height 80
  242. pack .cf1 \
  243. -in [winfo parent .cf1] \
  244. -anchor center \
  245. -expand 0 \
  246. -fill x \
  247. -side bottom
  248. CollapsableFrame .cf2 \
  249. -text "Frame2 " \
  250. -height 50 \
  251. -width 240
  252. pack .cf2 \
  253. -in [winfo parent .cf2] \
  254. -anchor center \
  255. -expand 0 \
  256. -fill x \
  257. -side bottom
  258. CollapsableFrame .cf3 \
  259. -text "Frame3 " \
  260. -height 80
  261. pack .cf3 \
  262. -in [winfo parent .cf3] \
  263. -anchor center \
  264. -expand 0 \
  265. -fill x \
  266. -side bottom
  267. # top bottom
  268. #-------
  269. # place child widgets inside the container
  270. #-------
  271. place [button [.cf1 getframe].but1 -text " Button A1" ] -x 10 -y 15
  272. place [button [.cf1 getframe].but2 -text " Button A2" ] -x 10 -y 45
  273.  
  274. place [button [.cf2 getframe].but1 -text " Button B1" ] -x 10 -y 15
  275. place [button [.cf2 getframe].but2 -text " Button B2" ] -x 85 -y 15
  276. place [button [.cf2 getframe].but3 -text " Button B3" ] -x 160 -y 15
  277.  
  278. place [button [.cf3 getframe].but1 -text " Button C1" ] -x 10 -y 15
  279. place [button [.cf3 getframe].but2 -text " Button C2" ] -x 10 -y 45
  280. }
  281.  
  282. demo