source: trunk/BWidget-1.2.1/color.tcl

Last change on this file was 931, checked in by toby, 11 years ago

include rest of files

File size: 10.3 KB
Line 
1# ------------------------------------------------------------------------------
2#  color.tcl
3#  This file is part of Unifix BWidget Toolkit
4# ------------------------------------------------------------------------------
5#  Index of commands:
6#     - SelectColor::create
7#     - SelectColor::setcolor
8#     - SelectColor::_destroy
9#     - SelectColor::_update_var
10#     - SelectColor::_post_menu
11#     - SelectColor::_tk_choose_color
12#     - SelectColor::_activate
13# ------------------------------------------------------------------------------
14
15namespace eval SelectColor {
16    Widget::declare SelectColor {
17        {-title    String     "" 0}
18        {-parent   String     "" 0}
19        {-type     Enum       dialog 1 {dialog menubutton}}
20        {-command  String     ""     0}
21        {-color    TkResource ""     0 {label -background}}
22        {-variable String     ""     0}
23        {-width    TkResource 15     0 frame}
24        {-height   TkResource 15     0 frame}
25    }
26
27    Widget::addmap      SelectColor "" :cmd {-width {} -height {}}
28    Widget::syncoptions SelectColor "" :cmd {-color -background}
29
30    variable _tabcolors {
31        \#0000ff \#000099 \#000000 white
32        \#00ff00 \#009900 \#333333 white
33        \#00ffff \#009999 \#666666 white
34        \#ff0000 \#990000 \#999999 white
35        \#ff00ff \#990099 \#cccccc white
36        \#ffff00 \#999900 \#ffffff
37    }
38
39    # bindings
40    bind SelectColor <ButtonPress-1> {SelectColor::_post_menu %W %X %Y}
41    bind SelectColor <Destroy>       {SelectColor::_destroy %W}
42
43    variable _widget
44
45    proc ::SelectColor { path args } { return [eval SelectColor::create $path $args] }
46    proc use {} {}
47}
48
49
50# ------------------------------------------------------------------------------
51#  Command SelectColor::create
52# ------------------------------------------------------------------------------
53proc SelectColor::create { path args } {
54    variable _tabcolors
55    variable _widget
56
57    Widget::init SelectColor $path $args
58
59    if { ![string compare [Widget::getoption $path -type] "menubutton"] } {
60        if { [set var [Widget::getoption $path -variable]] != "" } {
61            set _widget($path,var) $var
62            if { [GlobalVar::exists $var] } {
63                Widget::setoption $path -color [GlobalVar::getvar $var]
64            } else {
65                GlobalVar::setvar $var [Widget::getoption $path -color]
66            }
67            GlobalVar::tracevar variable $var w "SelectColor::_update_var $path"
68        } else {
69            set _widget($path,var) ""
70        }
71
72        eval frame $path [Widget::subcget $path :cmd] \
73            -background [Widget::getoption $path -color] \
74            -relief raised -borderwidth 2 -highlightthickness 0
75        bindtags $path [list $path SelectColor . all]
76        set _widget($path,idx) 0
77
78        rename $path ::$path:cmd
79        proc ::$path { cmd args } "return \[eval SelectColor::\$cmd $path \$args\]"
80    } else {
81        set parent [Widget::getoption $path -parent]
82        set title  [Widget::getoption $path -title]
83        set lopt   [list -initialcolor [Widget::getoption $path -color]]
84        if { [winfo exists $parent] } {
85            lappend lopt -parent $parent
86        }
87        if { $title != "" } {
88            lappend lopt -title $title
89        }
90        set col [eval tk_chooseColor $lopt]
91        Widget::destroy $path
92        return $col
93    }
94
95    return $path
96}
97
98
99# ------------------------------------------------------------------------------
100#  Command SelectColor::configure
101# ------------------------------------------------------------------------------
102proc SelectColor::configure { path args } {
103    variable _widget
104
105    set res [Widget::configure $path $args]
106
107    if { [Widget::hasChanged $path -variable var] } {
108        if { [string length $_widget($path,var)] } {
109            GlobalVar::tracevar vdelete $_widget($path,var) w "SelectColor::_update_var $path"
110        }
111        set _widget($path,var) $var
112        if { [string length $_widget($path,var)] } {
113            Widget::hasChanged $path -color curval
114            if { [GlobalVar::exists $_widget($path,var)] } {
115                Widget::setoption $path -color [set curval [GlobalVar::getvar $_widget($path,var)]]
116            } else {
117                GlobalVar::setvar $_widget($path,var) $curval
118            }
119            GlobalVar::tracevar variable $_widget($path,var) w "SelectColor::_update_var $path"
120            $path:cmd configure -background $curval
121        }
122    }
123
124    if { [Widget::hasChanged $path -color curval] } {
125        if { [string length $_widget($path,var)] } {
126            Widget::setoption $path -color [GlobalVar::getvar $_widget($path,var)]
127        } else {
128            $path:cmd configure -background $curval
129        }
130    }
131    return $res
132}
133
134
135# ------------------------------------------------------------------------------
136#  Command SelectColor::cget
137# ------------------------------------------------------------------------------
138proc SelectColor::cget { path option } {
139    return [Widget::cget $path $option]
140}
141
142
143# ------------------------------------------------------------------------------
144#  Command SelectColor::setcolor
145# ------------------------------------------------------------------------------
146proc SelectColor::setcolor { index color } {
147    variable _tabcolors
148    variable _widget
149
150    if { $index >= 1 && $index <= 5 } {
151        set idx        [expr {int($idx) * 3}]
152        set _tabcolors [lreplace $_tabcolors $idx $idx $color]
153        return 1
154    }
155    return 0
156}
157
158
159# ------------------------------------------------------------------------------
160#  Command SelectColor::_destroy
161# ------------------------------------------------------------------------------
162proc SelectColor::_destroy { path } {
163    variable _widget
164
165    if { [string length $_widget($path,var)] } {
166        GlobalVar::tracevar vdelete $_widget($path,var) w "SelectColor::_update_var $path"
167    }
168    unset _widget($path,var)
169    unset _widget($path,idx)
170    Widget::destroy $path
171    rename $path {}
172}
173
174
175# ------------------------------------------------------------------------------
176#  Command SelectColor::_update_var
177# ------------------------------------------------------------------------------
178proc SelectColor::_update_var { path args } {
179    variable _tabcolors
180    variable _widget
181
182    set col [GlobalVar::getvar $_widget($path,var)]
183    $path:cmd configure -background $col
184    Widget::setoption $path -color $col
185    set _widget($path,idx) [lsearch $_tabcolors $col]
186    if { $_widget($path,idx) == -1 } {
187        set _widget($path,idx) 0
188    }
189}
190
191
192# ------------------------------------------------------------------------------
193#  Command SelectColor::_post_menu
194# ------------------------------------------------------------------------------
195proc SelectColor::_post_menu { path X Y } {
196    global   env
197    variable _tabcolors
198    variable _widget
199
200    if { [winfo exists $path.menu] } {
201        if { [string compare [winfo containing $X $Y] $path] } {
202            BWidget::grab release $path
203            destroy $path.menu
204        }
205        return
206    }
207
208    set top [menu $path.menu]
209    wm withdraw $top
210    wm transient $top [winfo toplevel $path]
211    set col 0
212    set row 0
213    set count 0
214    set frame [frame $top.frame -highlightthickness 0 -relief raised -borderwidth 2]
215    foreach color $_tabcolors {
216        set f [frame $frame.c$count \
217                   -relief flat -bd 0 -highlightthickness 1 \
218                   -width 16 -height 16 -background $color]
219        bind $f <ButtonRelease-1> "SelectColor::_activate $path %W"
220        bind $f <Enter>           {focus %W}
221        grid $f -column $col -row $row -padx 1 -pady 1
222        bindtags $f $f
223        incr row
224        incr count
225        if { $row == 4 } {
226            set row 0
227            incr col
228        }
229    }
230    set f [label $frame.c$count \
231               -relief flat -bd 0 -highlightthickness 1 \
232               -width 16 -height 16 -image [Bitmap::get palette]]
233    grid $f -column $col -row $row -padx 1 -pady 1
234    bind $f <ButtonRelease-1> "SelectColor::_tk_choose_color $path"
235    bind $f <Enter>           {focus %W}
236    pack $frame
237
238    BWidget::place $top 0 0 below $path
239
240    wm deiconify $top
241    raise $top
242    focus $frame
243    focus $top.frame.c$_widget($path,idx)
244    BWidget::grab set $path
245}
246
247
248# ------------------------------------------------------------------------------
249#  Command SelectColor::_tk_choose_color
250# ------------------------------------------------------------------------------
251proc SelectColor::_tk_choose_color { path } {
252    variable _tabcolors
253    variable _widget
254
255    BWidget::grab release $path
256    destroy $path.menu
257    set parent [Widget::getoption $path -parent]
258    set title  [Widget::getoption $path -title]
259    set lopt   [list -initialcolor [$path:cmd cget -background]]
260    if { [winfo exists $parent] } {
261        lappend lopt -parent $parent
262    }
263    if { $title != "" } {
264        lappend lopt -title $title
265    }
266    set col [eval tk_chooseColor $lopt]
267    if { $col != "" } {
268        if { $_widget($path,idx) % 4 == 3 } {
269            set idx $_widget($path,idx)
270        } else {
271            set idx -1
272            for {set i 3} {$i < 15} {incr i 4} {
273                if { [lindex $_tabcolors $i] == "white" } {
274                    set idx $i
275                    break
276                }
277            }
278        }
279        if { $idx != -1 } {
280            set _tabcolors [lreplace $_tabcolors $idx $idx $col]
281            set _widget($path,idx) $idx
282        }
283        if { [info exists _widget($path,var)] } {
284            GlobalVar::setvar $_widget($path,var) $col
285        }
286        if { [set cmd [Widget::getoption $path -command]] != "" } {
287            uplevel \#0 $cmd
288        }
289        $path:cmd configure -background $col
290    }
291}
292
293
294# ------------------------------------------------------------------------------
295#  Command SelectColor::_activate
296# ------------------------------------------------------------------------------
297proc SelectColor::_activate { path cell } {
298    variable _tabcolors
299    variable _widget
300
301    BWidget::grab release $path
302    set col [$cell cget -background]
303    destroy $path.menu
304    if { [string length $_widget($path,var)] } {
305        GlobalVar::setvar $_widget($path,var) $col
306    }
307    Widget::setoption $path -color $col
308    $path:cmd configure -background $col
309
310    if { [set cmd [Widget::getoption $path -command]] != "" } {
311        uplevel \#0 $cmd
312    }
313    set _widget($path,idx) [string range [lindex [split $cell "."] end] 1 end]
314}
Note: See TracBrowser for help on using the repository browser.