1 | # ------------------------------------------------------------------------------ |
---|
2 | # labelframe.tcl |
---|
3 | # This file is part of Unifix BWidget Toolkit |
---|
4 | # $Id: labelframe.tcl,v 1.4 1999/07/09 11:49:17 eric Exp $ |
---|
5 | # ------------------------------------------------------------------------------ |
---|
6 | # Index of commands: |
---|
7 | # - LabelFrame::create |
---|
8 | # - LabelFrame::getframe |
---|
9 | # - LabelFrame::configure |
---|
10 | # - LabelFrame::cget |
---|
11 | # - LabelFrame::align |
---|
12 | # ------------------------------------------------------------------------------ |
---|
13 | |
---|
14 | namespace eval LabelFrame { |
---|
15 | Label::use |
---|
16 | |
---|
17 | Widget::bwinclude LabelFrame Label .l \ |
---|
18 | remove { |
---|
19 | -highlightthickness -highlightcolor -highlightbackground |
---|
20 | -takefocus -relief -borderwidth |
---|
21 | -bitmap -image -cursor -textvariable |
---|
22 | -dragenabled -draginitcmd -dragendcmd -dragevent -dragtype |
---|
23 | -dropenabled -droptypes -dropovercmd -dropcmd} \ |
---|
24 | initialize {-anchor w} |
---|
25 | |
---|
26 | Widget::declare LabelFrame { |
---|
27 | {-relief TkResource flat 0 frame} |
---|
28 | {-borderwidth TkResource 0 0 frame} |
---|
29 | {-side Enum left 1 {left right top bottom}} |
---|
30 | {-bd Synonym -borderwidth} |
---|
31 | } |
---|
32 | |
---|
33 | Widget::addmap LabelFrame "" :cmd {-background {}} |
---|
34 | Widget::addmap LabelFrame "" .f {-background {} -relief {} -borderwidth {}} |
---|
35 | |
---|
36 | Widget::syncoptions LabelFrame Label .l {-text {} -underline {}} |
---|
37 | |
---|
38 | bind BwLabelFrame <FocusIn> {Label::setfocus %W.l} |
---|
39 | bind BwLabelFrame <Destroy> {Widget::destroy %W; rename %W {}} |
---|
40 | |
---|
41 | proc ::LabelFrame { path args } { return [eval LabelFrame::create $path $args] } |
---|
42 | proc use {} {} |
---|
43 | } |
---|
44 | |
---|
45 | |
---|
46 | # ------------------------------------------------------------------------------ |
---|
47 | # Command LabelFrame::create |
---|
48 | # ------------------------------------------------------------------------------ |
---|
49 | proc LabelFrame::create { path args } { |
---|
50 | Widget::init LabelFrame $path $args |
---|
51 | |
---|
52 | set path [frame $path -background [Widget::getoption $path -background] \ |
---|
53 | -relief flat -bd 0 -takefocus 0 -highlightthickness 0] |
---|
54 | |
---|
55 | set label [eval Label::create $path.l [Widget::subcget $path .l] \ |
---|
56 | -takefocus 0 -highlightthickness 0 -relief flat -borderwidth 0 \ |
---|
57 | -dropenabled 0 -dragenabled 0] |
---|
58 | set frame [eval frame $path.f [Widget::subcget $path .f] \ |
---|
59 | -highlightthickness 0 -takefocus 0] |
---|
60 | |
---|
61 | switch [Widget::getoption $path -side] { |
---|
62 | left {set packopt "-side left"} |
---|
63 | right {set packopt "-side right"} |
---|
64 | top {set packopt "-side top -fill x"} |
---|
65 | bottom {set packopt "-side bottom -fill x"} |
---|
66 | } |
---|
67 | |
---|
68 | eval pack $label $packopt |
---|
69 | pack $frame -fill both -expand yes |
---|
70 | |
---|
71 | bindtags $path [list $path BwLabelFrame [winfo toplevel $path] all] |
---|
72 | |
---|
73 | rename $path ::$path:cmd |
---|
74 | proc ::$path { cmd args } "return \[eval LabelFrame::\$cmd $path \$args\]" |
---|
75 | |
---|
76 | return $path |
---|
77 | } |
---|
78 | |
---|
79 | |
---|
80 | # ------------------------------------------------------------------------------ |
---|
81 | # Command LabelFrame::getframe |
---|
82 | # ------------------------------------------------------------------------------ |
---|
83 | proc LabelFrame::getframe { path } { |
---|
84 | return $path.f |
---|
85 | } |
---|
86 | |
---|
87 | |
---|
88 | # ------------------------------------------------------------------------------ |
---|
89 | # Command LabelFrame::configure |
---|
90 | # ------------------------------------------------------------------------------ |
---|
91 | proc LabelFrame::configure { path args } { |
---|
92 | return [Widget::configure $path $args] |
---|
93 | } |
---|
94 | |
---|
95 | |
---|
96 | # ------------------------------------------------------------------------------ |
---|
97 | # Command LabelFrame::cget |
---|
98 | # ------------------------------------------------------------------------------ |
---|
99 | proc LabelFrame::cget { path option } { |
---|
100 | return [Widget::cget $path $option] |
---|
101 | } |
---|
102 | |
---|
103 | |
---|
104 | # ------------------------------------------------------------------------------ |
---|
105 | # Command LabelFrame::align |
---|
106 | # This command align label of all widget given by args of class LabelFrame |
---|
107 | # (or "derived") by setting their width to the max one +1 |
---|
108 | # ------------------------------------------------------------------------------ |
---|
109 | proc LabelFrame::align { args } { |
---|
110 | set maxlen 0 |
---|
111 | set wlist {} |
---|
112 | foreach wl $args { |
---|
113 | foreach w $wl { |
---|
114 | if { ![info exists Widget::_class($w)] } { |
---|
115 | continue |
---|
116 | } |
---|
117 | set class $Widget::_class($w) |
---|
118 | if { ![string compare $class "LabelFrame"] } { |
---|
119 | set textopt -text |
---|
120 | set widthopt -width |
---|
121 | } else { |
---|
122 | upvar 0 Widget::${class}::map classmap |
---|
123 | set textopt "" |
---|
124 | set widthopt "" |
---|
125 | set notdone 2 |
---|
126 | foreach {option lmap} [array get classmap] { |
---|
127 | foreach {subpath subclass realopt} $lmap { |
---|
128 | if { ![string compare $subclass "LabelFrame"] } { |
---|
129 | if { ![string compare $realopt "-text"] } { |
---|
130 | set textopt $option |
---|
131 | incr notdone -1 |
---|
132 | break |
---|
133 | } |
---|
134 | if { ![string compare $realopt "-width"] } { |
---|
135 | set widthopt $option |
---|
136 | incr notdone -1 |
---|
137 | break |
---|
138 | } |
---|
139 | } |
---|
140 | } |
---|
141 | if { !$notdone } { |
---|
142 | break |
---|
143 | } |
---|
144 | } |
---|
145 | if { $notdone } { |
---|
146 | continue |
---|
147 | } |
---|
148 | } |
---|
149 | set len [string length [$w cget $textopt]] |
---|
150 | if { $len > $maxlen } { |
---|
151 | set maxlen $len |
---|
152 | } |
---|
153 | lappend wlist $w $widthopt |
---|
154 | } |
---|
155 | } |
---|
156 | incr maxlen |
---|
157 | foreach {w widthopt} $wlist { |
---|
158 | $w configure $widthopt $maxlen |
---|
159 | } |
---|
160 | } |
---|