source: tol/tolbase/lib/toltk/toolbar.tcl @ 7b5e14e

1941-docker-image-to-testdevel
Last change on this file since 7b5e14e was 6d7779d, checked in by Jorge Pérez <josp.jorge@…>, 18 years ago

initial import

git-svn-id: ​https://www.tol-project.org/svn/tolp/trunk@1 be4846ae-f051-483a-831f-b64e7d08527f
  • Property mode set to 100644
File size: 59.3 KB
Line 
1##
2## toolbar.tcl --
3##
4##   A toolbar widget implementation.
5##
6## Copyright (c) 1999-2002 by:
7##   George Petasis,
8##   Institute of Informatics and Telecommunications,
9##   National Centre for Scientific Research "Demokritos",
10##   Aghia Paraskevi, Athens, Greece.
11##
12## Author contact information:
13##   e-mail: petasis@iit.demokritos.gr
14##   URL:    http://www.iit.demokritos.gr/~petasis
15##
16##
17## The following terms apply to all files associated
18## with the software unless explicitly disclaimed in individual files.
19##
20## The authors hereby grant permission to use, copy, modify, distribute,
21## and license this software and its documentation for any purpose, provided
22## that existing copyright notices are retained in all copies and that this
23## notice is included verbatim in any distributions. No written agreement,
24## license, or royalty fee is required for any of the authorized uses.
25## Modifications to this software may be copyrighted by their authors
26## and need not follow the licensing terms described here, provided that
27## the new terms are clearly indicated on the first page of each file where
28## they apply.
29##
30## IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
31## FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
32## ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
33## DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
34## POSSIBILITY OF SUCH DAMAGE.
35##
36## THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
37## INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
38## FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
39## IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
40## NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
41## MODIFICATIONS.
42##
43
44package require Tk
45package provide toolbar 1.0
46
47namespace eval ::toolbar {
48  namespace export ToolbarFrame create addbutton addwidget addseparator \
49                   activate deactivate
50  variable DefaultOption
51  variable ToolbarSpecifications
52}
53
54
55# ::toolbar::ToolbarFrame --
56#
57#        Creates a ToolbarFrame widget. This widget is a container that will
58#        contain one or more toolbar widgets.
59#
60# Arguments:
61#        toolbar_frame The name of the widget to be created
62#        args          Various configuration options
63#
64# Results:
65#        Creates a new widget and returns its name.
66proc ::toolbar::ToolbarFrame {toolbar_frame args} {
67  variable ToolbarSpecifications
68  variable DefaultOption
69  set frame_options [list -bg $DefaultOption(ToolbarBackground) \
70    -relief $DefaultOption(ToolbarFrameRelief) \
71    -borderwidth $DefaultOption(ToolbarFrameReliefBorderWidth)]
72  foreach {decorate orientation} [list $DefaultOption(ToolbarDecorate) H] {}
73  foreach {option value} $args {
74    switch -glob -- $option {
75      -decor* {
76        if {[string is true $value]} {set decorate 1}
77      }
78      -orien* {
79        if {[string match v* [string tolower $value]]} {
80          set orientation V
81        }
82      }
83      default {lappend frame_options $option $value}
84    }
85  }
86  eval frame $toolbar_frame -class ToolbarFrame $frame_options
87 
88  ## Make our toolbar frame draggable...
89  bind $toolbar_frame <<TMB_1>>     "::toolbar::Click $toolbar_frame"
90  #bind $toolbar_frame <<TMotion_1>> "::toolbar::Motion $toolbar_frame %X %Y"
91  set ToolbarSpecifications(Orientation:$toolbar_frame) $orientation
92  set ToolbarSpecifications(BorderWidth:$toolbar_frame) \
93      [$toolbar_frame cget -borderwidth]
94  set ToolbarSpecifications(Side:$toolbar_frame) top
95  bind $toolbar_frame <Destroy> \
96    {array unset ::toolbar::ToolbarSpecifications *:%W}
97  ## Toolbar Decoration...
98  if {$decorate} {
99    if {![string compare $orientation H]} {
100      bind $toolbar_frame <Configure> \
101       {if {[expr %h-2*${::toolbar::ToolbarSpecifications(BorderWidth:%W)}]<8} {
102          %W.toolbar_top_decoration configure    -bd 0 -height 1
103          %W.toolbar_bottom_decoration configure -bd 0 -height 1
104          %W configure -bd 0 -height 1
105        } else {
106          %W.toolbar_top_decoration configure    -bd 1 -height 2
107          %W.toolbar_bottom_decoration configure -bd 1 -height 2
108          %W configure -borderwidth \
109             ${::toolbar::ToolbarSpecifications(BorderWidth:%W)}
110        }}
111       frame $toolbar_frame.toolbar_top_decoration \
112             -relief sunken -bd 1 -height 2
113       frame $toolbar_frame.toolbar_bottom_decoration \
114             -relief sunken -bd 1 -height 2
115       pack  $toolbar_frame.toolbar_top_decoration -side top -fill x \
116             -expand 1 -pady 0 -ipady 0
117       pack  $toolbar_frame.toolbar_bottom_decoration -side bottom -fill x \
118             -expand 1 -pady 0 -ipady 0
119     } else { ;# Orientation...
120       bind $toolbar_frame <Configure> \
121       {if {[expr %w-2*${::toolbar::ToolbarSpecifications(BorderWidth:%W)}]<8} {
122          %W.toolbar_top_decoration configure    -bd 0 -width 1
123          %W.toolbar_bottom_decoration configure -bd 0 -width 1
124          %W configure -bd 0 -width 1
125        } else {
126          %W.toolbar_top_decoration configure    -bd 1 -width 2
127          %W.toolbar_bottom_decoration configure -bd 1 -width 2
128          %W configure -borderwidth \
129             ${::toolbar::ToolbarSpecifications(BorderWidth:%W)}
130        }}
131       frame $toolbar_frame.toolbar_top_decoration \
132             -relief sunken -bd 1 -width 2
133       frame $toolbar_frame.toolbar_bottom_decoration \
134             -relief sunken -bd 1 -width 2
135       pack  $toolbar_frame.toolbar_top_decoration -side left -fill y \
136             -expand 1 -pady 0 -ipady 0
137       pack  $toolbar_frame.toolbar_bottom_decoration -side right -fill y \
138             -expand 1 -pady 0 -ipady 0
139     }
140  } else {
141    bind $toolbar_frame <Configure> \
142     {if {[expr {%h-2*${::toolbar::ToolbarSpecifications(BorderWidth:%W)}}]<4} {
143        %W configure -bd 0 -height 1
144      } else {
145        %W configure -borderwidth \
146           ${::toolbar::ToolbarSpecifications(BorderWidth:%W)}
147      }}
148  }
149  return $toolbar_frame
150};# ::toolbar::ToolbarFrame
151
152
153# ::toolbar::create --
154#
155#        Creates a Toolbar widget. This widget is a container that will
156#       contain one or more button widgets....
157#
158# Arguments:
159#        toolbar       The name of the widget to be created. This widget should
160#                      be a child of a ToolbarFrame widget...
161#        args          Various configuration options
162#
163# Results:
164#        Creates a new widget and returns its name.
165proc ::toolbar::create {toolbar args} {
166  variable ToolbarSpecifications
167  variable DefaultOption
168  set frame_options [list -bd 0 -relief $DefaultOption(ToolbarRelief) \
169    -borderwidth $DefaultOption(ToolbarReliefBorderWidth)]
170  set ToolbarSpecifications(HideToolbar:$toolbar)  1
171  set ToolbarSpecifications(FloatToolbar:$toolbar) 1
172  foreach {arg val} $args {
173    switch -glob -- $arg {
174      -hide   {set ToolbarSpecifications(HideToolbar:$toolbar)  $val}
175      -float  {set ToolbarSpecifications(FloatToolbar:$toolbar) $val}
176      default {lappend frame_options $arg $val}
177    }
178  }
179  eval frame $toolbar -class Toolbar $frame_options
180  set toolbar_frame [winfo parent $toolbar]
181  bind $toolbar <<TMB_1>>     "::toolbar::Click $toolbar_frame"
182  #bind $toolbar <<TMotion_1>> "::toolbar::Motion $toolbar_frame %X %Y"
183  set orientation $ToolbarSpecifications(Orientation:$toolbar_frame)
184  set bg $DefaultOption(ToolbarBackground)
185  set hfg $bg
186  set ToolbarSpecifications(BorderWidth:$toolbar) [$toolbar cget -borderwidth]
187  if {$DefaultOption(ToolbarImageHandle)} {
188    if {![string compare $orientation H]} {
189      set Image IToolbar
190    } else {
191      set Image IToolbarVertical
192    }
193    button $toolbar.handle -background $DefaultOption(ToolbarHandleBackground) \
194       -activebackground $DefaultOption(ToolbarHandleBackground) \
195       -relief $DefaultOption(ToolbarHandleRelief) -anchor nw \
196       -borderwidth $DefaultOption(ToolbarHandleReliefBorderWidth) \
197       -image $Image -highlightcolor $DefaultOption(ToolbarHandleBackground) \
198       -highlightthickness 0 -command "::toolbar::HandleCallback $toolbar 1"
199    if {$ToolbarSpecifications(HideToolbar:$toolbar)} {
200      bind $toolbar.handle <Double-Button-2> \
201         "::toolbar::HandleCallback $toolbar 2"
202      bind $toolbar.handle <Double-Button-3> \
203         "::toolbar::HandleCallback $toolbar 2"
204    }
205    bind $toolbar.handle <<TMB_1>>     "::toolbar::Click $toolbar_frame"
206    #bind $toolbar.handle <<TMotion_1>> "::toolbar::Motion $toolbar_frame %X %Y"
207    bind $toolbar.handle <<TMB_2>>    "::toolbar::ContextSensitiveMenu $toolbar"
208  } else {
209    if {[string equal $::tcl_platform(platform) windows]} {
210      set HandleRelief ridge
211    } else {
212      set HandleRelief raised
213    }
214    frame $toolbar.handle -relief flat -bd 1 \
215      -background $DefaultOption(ToolbarBackground)
216    if {![string compare $orientation H]} {
217      frame $toolbar.handle.l1 -relief $HandleRelief -bd 1 -width 2 \
218        -background $DefaultOption(ToolbarHandleBackground)
219      frame $toolbar.handle.l2 -relief $HandleRelief -bd 1 -width 2 \
220        -background $DefaultOption(ToolbarHandleBackground)
221      pack $toolbar.handle.l1 -fill y -side left -padx 2 -pady 2
222      #Pedro pady 14 ... primer Boton siempre de ese tamaño
223      pack $toolbar.handle.l2 -fill y -side left -pady 13
224    } else {
225      frame $toolbar.handle.l1 -relief $HandleRelief -bd 1 -height 2 \
226        -background $DefaultOption(ToolbarHandleBackground)
227      frame $toolbar.handle.l2 -relief $HandleRelief -bd 1 -height 2 \
228        -background $DefaultOption(ToolbarHandleBackground)
229      pack $toolbar.handle.l1 -fill x -side top -pady 1 -padx 2
230      pack $toolbar.handle.l2 -fill x -side top -padx 2
231    }
232    foreach _han [list $toolbar.handle $toolbar.handle.l1 $toolbar.handle.l2] {
233      bind ${_han} <Double-Button-1>  "::toolbar::HandleCallback $toolbar 1"
234      if {$ToolbarSpecifications(HideToolbar:$toolbar)} {
235        bind ${_han} <Double-Button-2> "::toolbar::HandleCallback $toolbar 2"
236        bind ${_han} <Double-Button-3> "::toolbar::HandleCallback $toolbar 2"
237      }
238      bind ${_han} <<TMB_1>>     "::toolbar::Click $toolbar_frame"
239     #bind ${_han} <<TMotion_1>> "::toolbar::Motion $toolbar_frame %X %Y"
240      bind ${_han} <<TMB_2>>     "::toolbar::ContextSensitiveMenu $toolbar"
241    }
242    bind $toolbar.handle <Enter> "%W configure -relief $HandleRelief"
243    bind $toolbar.handle <Leave> "%W configure -relief flat"
244  }
245  frame $toolbar.widgets -relief flat -bd 0 -bg $bg
246  bind $toolbar <Destroy> \
247    {catch {array unset ::toolbar::ToolbarSpecifications *:%W}}
248  deiconify $toolbar
249  return $toolbar
250};# ::toolbar::create
251
252
253# ::toolbar::addbutton --
254#
255#        Creates a button in a toolbar widget....
256#
257# Arguments:
258#        toolbar       The name of the widget to be created. This widget should
259#                      be a child of a ToolbarFrame widget...
260#        args          Various configuration options
261#
262# Results:
263#        Creates a new button in a toolbar and returns its name.
264proc ::toolbar::addbutton {toolbar args} {
265  variable ToolbarSpecifications
266  variable DefaultOption
267  foreach {cmd image overimage bitmap bw relief overrelief win_nu} \
268          {{}  {}    {}        {}     1  flat   raised    0} {break}
269  while {1} {
270    set name $toolbar.widgets.$win_nu
271    if {![winfo exists $name]} {break}
272    incr win_nu
273  }
274  set text $win_nu
275  foreach {tooltip tooltipvar} {{} {}} {}
276  set bg $DefaultOption(ToolbarBackground)
277  set hfg {}
278
279  ## Get options...
280  for {set i 0;set num [llength $args];set cargs {}} {$i<$num} {incr i} {
281    set arg [lindex $args $i]
282    set val [lindex $args [incr i]]
283    switch -glob -- $arg {
284     -c*          {append cmd $val       ;# -command}
285     -i*          {set image $val        ;# -image}
286     -bi*         {set bitmap $val       ;# -bitmap}
287     -bo*         {set bw $val           ;# -borderwidth}
288     -a*          {set hfg $val          ;# -activebackground}
289     -r*          {set relief $val       ;# -relief}
290     -n*          {set name $val         ;# -name}
291     -overi*      {set overimage  $val   ;# -overimage}
292     -overr*      {set overrelief $val   ;# -overrelief}
293     -statusw*    {set statuswidget $val ;# -statuswidget}
294     -statusv*    {set statusvar $val    ;# -statusvar}
295     -text        {set text $val         ;# -text}
296     -textvar*    {set textvariable $val ;# -textvariable}
297     -tooltip     {set tooltip $val      ;# -tooltip}
298     -tooltipvar* {set tooltipvar $val   ;# -tooltipvariable}
299     default { return -code error "unknown option \"$arg\"" }
300    }
301  }
302  set cmd \
303    "$name configure -cursor watch; $cmd;\
304     catch \"$name configure -cursor {}; $name configure -relief flat\""
305
306  ## Create the toolbar button...
307  if {[string length $image]} {
308    button $name -command "$cmd" -relief $relief \
309      -image $image -background $bg -borderwidth $bw \
310      -highlightbackground $bg -activebackground $bg
311  } elseif {[string length $bitmap]} {
312    button $name -command "$cmd" -relief $relief \
313      -bitmap $bitmap -background $bg -borderwidth $bw \
314      -highlightbackground $bg -activebackground $bg
315  } else {
316    button $name -command "$cmd" -relief $relief \
317      -text $text -background $bg -borderwidth $bw
318  }
319  if {[string length $hfg]} {$name configure -activebackground $hfg}
320  if {[info exists textvariable]} {
321     $name configure -textvariable $textvariable
322  }
323  set toplevel [winfo toplevel $name]
324  bind $name <Enter> \
325    "%W configure -relief $overrelief;::toolbar::Tooltip show %W $toolbar"
326  bind $name <Leave> \
327    "%W configure -relief $relief;::toolbar::Tooltip cancel %W $toolbar"
328  if {[string length $tooltipvar]} {
329    set ToolbarSpecifications(TooltipVar:$name:$toolbar) $tooltipvar
330  } elseif {[string length $tooltip]} {
331    set ToolbarSpecifications(Tooltip:$name:$toolbar) $tooltip
332  }
333  if {[info exists statuswidget]} {
334    set ToolbarSpecifications(StatusWidget:$name:$toolbar) $statuswidget
335  } elseif {[info exists statusvar]} {
336    set ToolbarSpecifications(StatusVar:$name:$toolbar) $statusvar
337  }
338   
339  if {![string compare \
340    $ToolbarSpecifications(Orientation:[winfo parent $toolbar]) H]} {
341    pack $name -side left -ipadx 2 -ipady 2 -pady 1 -fill y
342   
343  } else {
344    pack $name -side top  -ipadx 2 -ipady 2 -padx 1 -fill x
345  }
346  return $name
347};# ::toolbar::addbutton
348
349
350# ::toolbar::addwidget --
351#
352#        Create and place a widget inside a toolbar widget....
353#
354# Arguments:
355#        toolbar       The name of the widget to be created. This widget should
356#                      be a child of a ToolbarFrame widget...
357#       widget        the type of the widget to be created (like label, etc)
358#        args          Various configuration options
359#
360# Results:
361#        Creates a new widget inside a toolbar and returns its name.
362proc ::toolbar::addwidget {toolbar widget args} {
363  variable ToolbarSpecifications
364  variable DefaultOption
365  foreach {win_nu widget_args relief bw entercmd leavecmd} \
366          {0 {} raised 1 {} {}} {}
367  while {1} {
368    set name $toolbar.widgets.$win_nu
369    if {![winfo exists $name]} {break}
370    incr win_nu
371  }
372  foreach {tooltip tooltipvar pady} {{} {} 1} {}
373  set bg $DefaultOption(ToolbarBackground)
374
375  ## Get options...
376  for {set i 0;set num [llength $args];set cargs {}} {$i<$num} {incr i} {
377    set arg [lindex $args $i]
378    set val [lindex $args [incr i]]
379    switch -glob -- $arg {
380     -bg          -
381     -backgr*     {set bg $val           ;# -background}
382     -bd          -
383     -borderw*    {set bw $val           ;# -borderwidth}
384     -enterc*     {set entercmd $val     ;# -entercommand}
385     -name        {set name $val         ;# -name}
386     -leavec*     {set leavecmd $val     ;# -leavecommand}
387     -rel*        {set relief $val       ;# -relief}
388     -statusw*    {set statuswidget $val ;# -statuswidget}
389     -statusv*    {set statusvar $val    ;# -statusvar}
390     -tooltip     {set tooltip $val      ;# -tooltip}
391     -tooltipvar* {set tooltipvar $val   ;# -tooltipvariable}
392     -pady        {set pady $val         ;# -pady}
393     default      {lappend widget_args $arg $val }
394    }
395  }
396
397  ## Create the widget...
398  eval [list $widget] [list $name] $widget_args -relief flat -borderwidth $bw \
399       -background $bg
400  switch $widget {
401    label   {}
402    default {}
403  }
404  set ToolbarSpecifications(ExWidgetCmd:$name) \
405     [concat $widget $name $widget_args -relief flat -borderwidth $bw]
406  bind $name <Destroy> \
407      {catch {unset ::toolbar::ToolbarSpecifications(ExWidgetCmd:%W)}}
408   
409  set toplevel [winfo toplevel $name]
410  if {![string length $entercmd]} {
411    bind $name <Enter> \
412    "%W configure -relief $relief;::toolbar::Tooltip show %W $toolbar"
413  } else {
414    bind $name <Enter> \
415    "%W configure -relief $relief;::toolbar::Tooltip show %W $toolbar;$entercmd"
416  }
417  if {![string length $leavecmd]} {
418    bind $name <Leave> \
419    "%W configure -relief flat;::toolbar::Tooltip cancel %W $toolbar"
420  } else {
421    bind $name <Leave> \
422    "%W configure -relief flat;::toolbar::Tooltip cancel %W $toolbar;$leavecmd"
423  }
424  if {[string length $tooltipvar]} {
425    set ToolbarSpecifications(TooltipVar:$name:$toolbar) $tooltipvar
426  } elseif {[string length $tooltip]} {
427    set ToolbarSpecifications(Tooltip:$name:$toolbar) $tooltip
428  }
429  if {[info exists statuswidget]} {
430    set ToolbarSpecifications(StatusWidget:$name:$toolbar) $statuswidget
431  } elseif {[info exists statusvar]} {
432    set ToolbarSpecifications(StatusVar:$name:$toolbar) $statusvar
433  }
434
435  if {![string compare \
436          $ToolbarSpecifications(Orientation:[winfo parent $toolbar]) H]} {
437    pack $name -side left -ipadx 2 -ipady 2 -pady $pady -fill y
438  } else {
439    pack $name -side top  -ipadx 2 -ipady 2 -padx $pady -fill x
440  }
441  return $name
442};# ::toolbar::addwidget
443
444
445# ::toolbar::addseparator --
446#
447#        Create and place a separator inside a toolbar widget....
448#
449# Arguments:
450#        toolbar       The name of the widget to be created. This widget should
451#                      be a child of a ToolbarFrame widget...
452#        args          Various configuration options
453#
454# Results:
455#        Creates a new separator in a toolbar and returns its name.
456proc ::toolbar::addseparator {toolbar args} {
457  variable ToolbarSpecifications
458  variable DefaultOption
459
460  foreach {win_nu orientation attachto} {0 vertical {}} {}
461  while {1} {
462    set name $toolbar.widgets.$win_nu
463    if {![winfo exists $name]} {break}
464    incr win_nu
465  }
466  foreach {opt val} $args {
467    switch -glob -- $opt {
468      -orien*  {set orientation $val}
469      -name    {set name $val}
470      -atta*   {set attachto $val ;# -attach: a list of widgets that control\
471                                      show/hide...}
472      default  {error "addseparator: unknown option $opt..."}
473    }
474  }
475  switch -glob -- $orientation {
476    ver*  { set orientation \
477               $ToolbarSpecifications(Orientation:[winfo parent $toolbar])
478            if {[string equal $orientation H]} {
479              frame $name -relief sunken -bd 1 -width 2 \
480                -background $DefaultOption(ToolbarHandleBackground)
481              pack $name -side left -pady 4 -padx 4 -fill y
482            } else {
483              frame $name -relief sunken -bd 1 -height 2 \
484                -background $DefaultOption(ToolbarHandleBackground)
485              pack $name -side top -pady 4 -padx 4 -fill x
486            }
487          }
488    hor*  { frame $name -relief sunken -bd 1 -height 2 \
489                -background $DefaultOption(ToolbarHandleBackground)
490            pack $name -side top -anchor w -padx 0 -fill x -expand 1
491            set parent [winfo parent $name]
492            bind $parent <Configure> \
493               "+::toolbar::ManageHorizontalSeparator $parent $name"
494            lappend attachto $toolbar
495            foreach toolbar $attachto {
496              bind $toolbar <<ToolBarHide>> "$name configure -bd 0 -height 1"
497              bind $toolbar <<ToolBarShow>> "$name configure -bd 1 -height 2"
498            } }
499    default {error \
500        "addseparator: unknown value $orientation for parameter orientation"}
501  }
502  return $name
503};# ::toolbar::addseparator
504#
505#  This proc is called only when a horizontal separator exists. It catches
506#    configure event of the separator parent, and hides the separator if it is
507#    the last element of the parent (all toolbars below have been hiden...)
508#
509proc ::toolbar::ManageHorizontalSeparator {parent window} {
510  set ParentHeight [winfo height $parent]
511  if {$ParentHeight < 2} {return}
512  set y [winfo y $window]
513  if {$y > $ParentHeight} {$window configure -bd 0 -height 1}
514};# ::toolbar::ManageHorizontalSeparator
515
516
517# ::toolbar::activate --
518#
519#        Makes a toolbar widget active.
520#
521# Arguments:
522#        toolbar       The name of the widget to be created. This widget should
523#                      be a child of a ToolbarFrame widget...
524#
525# Results:
526#        Makes a toolbar active to user input.
527proc ::toolbar::activate {toolbar} {
528  variable ToolbarSpecifications
529  foreach child [winfo children $toolbar.widgets] {
530    catch {$child configure -state normal}
531    catch {bind $child <Enter>  $ToolbarSpecifications($child:<Enter>)
532           bind $child <Leave>  $ToolbarSpecifications($child:<Leave>)
533           bind $child <Motion> $ToolbarSpecifications($child:<Motion>)}
534  }
535
536  ## Activate floating window, if any...
537  set win $toolbar.fltWin
538  if [winfo exists $win] {
539    foreach child [winfo children $win] \
540            or_child [winfo children $toolbar.widgets] {
541      catch {$child configure -state normal}
542      catch {bind $child <Enter>  $ToolbarSpecifications($or_child:<Enter>)
543             bind $child <Leave>  $ToolbarSpecifications($or_child:<Leave>)
544             bind $child <Motion> $ToolbarSpecifications($or_child:<Motion>)}
545    }
546  }
547  foreach child [winfo children $toolbar.widgets] {
548    catch {unset ToolbarSpecifications($child:<Enter>) \
549                 ToolbarSpecifications($child:<Leave>) \
550                 ToolbarSpecifications($child:<Motion>)}
551  }
552};# ::toolbar::activate
553
554
555# ::toolbar::deactivate --
556#
557#        Makes a toolbar widget inactive.
558#
559# Arguments:
560#        toolbar       The name of the widget to be created. This widget should
561#                      be a child of a ToolbarFrame widget...
562#
563# Results:
564#        Makes a toolbar inactive to user input.
565proc ::toolbar::deactivate {toolbar} {
566  variable ToolbarSpecifications
567  foreach child [winfo children $toolbar.widgets] {
568    catch {$child configure -state disabled}
569    catch {
570        set ToolbarSpecifications($child:<Enter>)  [bind $child <Enter>]
571        set ToolbarSpecifications($child:<Leave>)  [bind $child <Leave>]
572        set ToolbarSpecifications($child:<Motion>) [bind $child <Motion>]}
573    catch {bind $child <Enter>  {}}
574    catch {bind $child <Leave>  {}}
575    catch {bind $child <Motion> {}}
576  }
577  ## Deactivate floating window, if any...
578  set win $toolbar.fltWin
579  if {[winfo exists $win]} {
580    foreach child [winfo children $win] {
581      catch {$child configure -state disabled}
582      catch {bind $child <Enter>  {}}
583      catch {bind $child <Leave>  {}}
584      catch {bind $child <Motion> {}}
585    }
586  }
587};# ::toolbar::deactivate
588
589
590# ::toolbar::deiconify --
591#
592#        Makes a toolbar widget visible. This is an internal function and
593#        should not be call by users...
594#
595# Arguments:
596#        args          The name(s) of the toolbar widgets to make visible
597#
598# Results:
599#        Makes a toolbar widget visible by packing its components.
600proc ::toolbar::deiconify {args} {
601  variable ToolbarSpecifications
602  foreach toolbar $args {
603    if {[winfo exists $toolbar]} {
604      ## Is the toolbar visible in a floating window?
605      if [winfo exists $toolbar.fltWin] {continue}
606      if {![string compare \
607          $ToolbarSpecifications(Orientation:[winfo parent $toolbar]) H]} {
608        pack $toolbar.handle -side left -fill y
609        pack $toolbar.widgets -side left -fill y
610      } else {
611        pack $toolbar.handle -side top -fill x
612        pack $toolbar.widgets -side top -fill x
613      }
614      $toolbar configure -bd $ToolbarSpecifications(BorderWidth:$toolbar)
615      event generate $toolbar <<ToolBarShow>>
616    }
617  }
618};# ::toolbar::deiconify
619
620
621# ::toolbar::SetOrientation --
622#
623#        Try to change the orientation of a toolbar frame (and thus all the
624#       toolbars contained in it) to the given one...
625#
626# Arguments:
627#        toolbar       The name of the toolbar frame.
628#        orientation   The desired orientation (H|V, defaults to H)
629#
630# Results:
631#        Change the orientation of a toolbar frame and all the toolbars
632#        contained inside the toolbar frame.
633proc ::toolbar::SetOrientation {toolbar {orientation H}} {
634  variable ToolbarSpecifications
635  variable DefaultOption
636  set ToolbarSpecifications(Orientation:$toolbar) $orientation
637  set child_toolbars [winfo children $toolbar]
638  switch $orientation {
639    H {
640      eval pack forget $child_toolbars
641      ## Has the frame any decorations?
642      if {[winfo exists $toolbar.toolbar_top_decoration]} {
643        $toolbar.toolbar_top_decoration    conf -height 2 -width 0
644        $toolbar.toolbar_bottom_decoration conf -height 2 -width 0
645        pack $toolbar.toolbar_top_decoration    -side top -fill x \
646             -expand 1 -pady 0 -ipady 0
647        pack $toolbar.toolbar_bottom_decoration -side bottom -fill x \
648             -expand 1 -pady 0 -ipady 0
649      }
650      foreach child_toolbar $child_toolbars {
651        ## Is this toolbar in a floating window?
652        if {[winfo exists $child_toolbar.fltWin]} {continue}
653        ## Is this a real toolbar, or a separator?
654        if {![llength [winfo children $child_toolbar]]} {
655          ## A frame with no children? A separator...
656          #pack $child_toolbar -side top -pady 4 -padx 4 -fill x
657          continue   
658        }
659        set slaves [pack slaves $child_toolbar.widgets]
660        ## We have removed all windows from the toolbar
661        pack forget $child_toolbar.handle $child_toolbar.widgets
662        eval pack forget $slaves
663        if {$DefaultOption(ToolbarImageHandle)} {
664          $child_toolbar.handle configure -image IToolbar
665        } else {
666          pack forget $child_toolbar.handle.l1 $child_toolbar.handle.l2
667          $child_toolbar.handle.l1 configure -width 2 -height 0
668          $child_toolbar.handle.l2 configure -width 2 -height 0
669          pack $child_toolbar.handle.l1 -fill y -side left -padx 1 -pady 2
670          pack $child_toolbar.handle.l2 -fill y -side left -pady 2
671        }
672        ## Now, re-pack everything...
673        pack $child_toolbar.handle $child_toolbar.widgets -side left -fill y \
674          -pady 0 -padx 0
675        foreach widget $slaves {
676          if {[string equal -nocase [winfo class $widget] frame] &&
677              ![llength [winfo children $widget]]} {
678            ## This is a separator...
679            $widget configure -relief sunken -bd 1 -width 2 -height 0
680            pack $widget -side left -pady 4 -padx 4 -fill y
681          } else {
682            pack $widget -side left -ipadx 2 -ipady 2 -pady 1 -fill y
683          }
684        }
685      }
686      ## Now its time to pack the toolbars...
687      set height [winfo width $toolbar]
688      incr height -20
689      foreach child $child_toolbars {
690        ## Is this toolbar in a floating window?
691        ##if {[winfo exists $child.fltWin]} {continue}
692        ## Is this a real toolbar, or a separator?
693        if {![llength [winfo children $child]]} {
694          ## A frame with no children? A separator...
695          update idle
696          pack $child -side top -anchor sw -padx 0 -fill x -expand 1
697          continue   
698        }
699        pack $child -side left
700        if {[winfo x $child] > $height} {
701          pack forget $child
702          pack $child -side bottom
703        }
704      }
705    }
706    V {
707      eval pack forget $child_toolbars
708      ## Has the frame any decorations?
709      if {[winfo exists $toolbar.toolbar_top_decoration]} {
710        $toolbar.toolbar_top_decoration    conf -height 0 -width 2
711        $toolbar.toolbar_bottom_decoration conf -height 0 -width 2
712        pack $toolbar.toolbar_top_decoration    -side left -fill y \
713             -expand 1 -pady 0 -ipady 0
714        pack $toolbar.toolbar_bottom_decoration -side right -fill y \
715             -expand 1 -pady 0 -ipady 0
716      }
717      foreach child_toolbar $child_toolbars {
718        ## Is this toolbar in a floating window?
719        if {[winfo exists $child_toolbar.fltWin]} {continue}
720        ## Is this a real toolbar, or a separator?
721        if {![llength [winfo children $child_toolbar]]} {
722          ## A frame with no children? A separator...
723          #pack $child_toolbar -side left -pady 4 -padx 4 -fill y
724          continue   
725        }
726        set slaves [pack slaves $child_toolbar.widgets]
727        ## We have removed all windows from the toolbar
728        pack forget $child_toolbar.handle $child_toolbar.widgets
729        eval pack forget $slaves
730        if {$DefaultOption(ToolbarImageHandle)} {
731          $child_toolbar.handle configure -image IToolbarVertical
732        } else {
733          pack forget $child_toolbar.handle.l1 $child_toolbar.handle.l2
734          $child_toolbar.handle.l1 configure -width 0 -height 2 -bd 1
735          $child_toolbar.handle.l2 configure -width 0 -height 2 -bd 1
736          pack $child_toolbar.handle.l1 -fill x -side top -pady 1 -padx 2
737          pack $child_toolbar.handle.l2 -fill x -side top -padx 2
738        }
739        ## Now, re-pack everything...
740        pack $child_toolbar.handle $child_toolbar.widgets -side top -fill x \
741          -pady 0 -padx 0
742        foreach widget $slaves {
743          if {[string equal -nocase [winfo class $widget] frame] &&
744              ![llength [winfo children $widget]]} {
745            ## This is a separator...
746            $widget configure -relief sunken -bd 1 -width 0 -height 2
747            pack $widget -side top -pady 4 -padx 4 -fill x
748          } else {
749            pack $widget -side top -ipadx 2 -ipady 2 -padx 1 -fill x
750          }
751        }
752      }
753      set height [winfo height $toolbar]
754      incr height -20
755      foreach child $child_toolbars {
756        ## Is this toolbar in a floating window?
757        #if {[winfo exists $child.fltWin]} {continue}
758        if {![llength [winfo children $child]]} {
759          ## A frame with no children? A separator...
760          pack $child -side left -fill y
761          continue   
762        }
763        pack $child -side top
764        if {[winfo y $child] > $height} {
765          pack forget $child
766          pack $child -side left
767        }
768      }
769    }
770    default {error "unknown orientation $orientation"}
771  }
772  event generate $toolbar <<ToolBarShow>>
773};# ::toolbar::SetOrientation
774
775
776# ::toolbar::CreateToolbarWindow --
777#
778#        Convert a toolbar widget into a floating window. This function
779#        actually hides the toolbar and creates a toplevel window that is an
780#        exact replica of the toolbar widget. This is an internal function and
781#        should never be called by the user...
782#
783# Arguments:
784#        toolbar       The name of the toolbar widget.
785#
786# Results:
787#        Turn a toolbar into a floating window.
788proc ::toolbar::CreateToolbarWindow {toolbar} {
789  variable ToolbarSpecifications
790  variable DefaultOption
791  set win $toolbar.fltWin
792  if [winfo exists $win] {return}
793  toplevel $win -bg $DefaultOption(ToolbarBackground)
794  wm withdraw $win
795  wm transient $win [winfo toplevel $toolbar]
796  wm title $win Toolbar
797  bind $win <Destroy> \
798     "::toolbar::deiconify $toolbar
799      [winfo parent $toolbar] configure \
800            -height [winfo height [winfo parent $toolbar]]
801      array unset ::toolbar::ToolbarSpecifications X1:*"
802  after 600 "bind $win <Configure>  \
803     \"::toolbar::MountFloat [winfo parent $toolbar] $toolbar %W %x %y\""
804  bind [winfo toplevel $toolbar] <Destroy> \
805   "+catch \"destroy $win\""
806
807  ## Create the new widgets...
808  foreach child [winfo children $toolbar.widgets] {
809    set widget [DuplicateWidget $win $child]
810    if {![string length $widget]} {continue}
811
812    ## Has the old widget a tooltip assosiated with it?
813    if {[info exists ToolbarSpecifications(TooltipVar:$child:$toolbar)]} {
814      set ToolbarSpecifications(TooltipVar:$widget:$toolbar) \
815         $ToolbarSpecifications(TooltipVar:$child:$toolbar)
816      bind $widget <Destroy> "catch \"unset ::toolbar::ToolbarSpecifications(TooltipVar:$widget:$toolbar)\""
817    }
818    if {[info exists ToolbarSpecifications(Tooltip:$child:$toolbar)]} {
819      set ToolbarSpecifications(Tooltip:$widget:$toolbar) \
820         $ToolbarSpecifications(Tooltip:$child:$toolbar)
821      bind $widget <Destroy> "+catch \"unset ::toolbar::ToolbarSpecifications(Tooltip:$widget:$toolbar)\""
822    }
823    ## Is the old widget associated with a status bar?
824    if {[info exists ToolbarSpecifications(StatusWidget:$child:$toolbar)]} {
825      set ToolbarSpecifications(StatusWidget:$widget:$toolbar) \
826        $ToolbarSpecifications(StatusWidget:$child:$toolbar)
827      bind $widget <Destroy> "+catch \"unset ::toolbar::ToolbarSpecifications(StatusWidget:$widget:$toolbar)\""
828    }
829    if {[info exists ToolbarSpecifications(StatusVar:$child:$toolbar)]} {
830      set ToolbarSpecifications(StatusVar:$widget:$toolbar) \
831        $ToolbarSpecifications(StatusVar:$child:$toolbar)
832      bind $widget <Destroy> "+catch \"unset ::toolbar::ToolbarSpecifications(StatusVar:$widget:$toolbar)\""
833    }
834    if {[info exists ToolbarSpecifications(StatusPrev:$child:$toolbar)]} {
835      set ToolbarSpecifications(StatusPrev:$widget:$toolbar) \
836        $ToolbarSpecifications(StatusPrev:$child:$toolbar)
837      bind $widget <Destroy> "+catch \"unset ::toolbar::ToolbarSpecifications(StatusPrev:$widget:$toolbar)\""
838    }
839    if {[string equal -nocase [winfo class $widget] frame]} {
840      pack $widget -side left -pady 4 -padx 4 -fill y
841    } else {
842      pack $widget -side left -ipadx 2 -ipady 2 -pady 1 -fill y
843    }
844  }
845  update
846  wm geometry $win \
847    +[expr [winfo pointerx $win]-([winfo reqwidth $win]/2)]+[expr \
848           [winfo pointery $win]-15]
849  wm deiconify $win
850};# ::toolbar::CreateToolbarWindow
851#
852# Create a "miror" widget
853#
854proc ::toolbar::DuplicateWidget {parent w2 {pack 0}} {
855  variable ToolbarSpecifications
856  variable DefaultOption
857  set win_nu 0
858  while 1 {
859    set w1 $parent.$win_nu
860    if {![winfo exists $w1]} {break}
861    incr win_nu
862  }
863  switch -exact -- [winfo class $w2] {
864      Button {button $w1}
865      Frame  {
866        if {[info exists ToolbarSpecifications(ExWidgetCmd:$w2)]} {
867          if {[llength $ToolbarSpecifications(ExWidgetCmd:$w2)]} {
868            ## Its an external widget...
869            set cmd [lreplace $ToolbarSpecifications(ExWidgetCmd:$w2) 1 1 $w1]
870            #puts $cmd
871            eval $cmd
872          } else {
873            #puts HELP!!!!!!!!!!!!!!!!!!!
874          }
875        } else {
876          if {[llength [winfo children $w2]]} {
877            #puts "Help! !!!!"
878          } else {
879            ## its a separator...
880            frame $w1 -relief sunken -bd 1 -width 2
881            if {$pack} {pack $w1}
882            return $w1
883          }
884        }
885      }
886      Label  {label $w1}
887      ArrowButton {ArrowButton $w1}
888      default {
889        if {[catch {[string tolower [winfo class $w2]] $w1}]} {
890          return
891        }
892      }
893  }
894  ## Configure the new widget
895  foreach option [$w2 configure] {
896    set spec [lindex $option 0]
897    catch {$w1 configure $spec [$w2 cget $spec]}
898  }
899
900  ## Add Bindings
901  foreach Tag [bind $w2] {
902     bind $w1 $Tag [bind $w2 $Tag]
903  }
904
905  ## Menubuttons are a special case...
906  if {[string equal [winfo class $w2] Menubutton]} {
907    set menu [$w2 cget -menu]
908    $menu clone $w1.menu
909    $w1 configure -menu $w1.menu
910  }
911  if {$pack} {pack $w1}
912  return $w1
913};# ::toolbar::DuplicateWidget
914
915
916#
917# Mount Float Window into toplevel window
918#
919# ::toolbar::MountFloat --
920#
921#        Convert a toolbar from a floating window into a widget. This function
922#        actually shows a hidden toolbar widget and destroys a toplevel window
923#       that is an exact replica of the toolbar widget.
924#       This is an internal function and should never be called by the user...
925#
926# Arguments:
927#        toolbar       The name of the toolbar widget.
928#
929# Results:
930#        Turn a toolbar into a floating window.
931proc ::toolbar::MountFloat {parent toolbar win x y} {
932  if {![winfo exists $win]} {return}
933  variable ToolbarSpecifications
934  variable DefaultOption
935  $parent configure -height [winfo height $parent] \
936                    -width  [winfo width  $parent]
937  set starty [winfo rooty $parent]
938  catch {after cancel $ToolbarSpecifications(AfterID)}
939  if {$y > $starty - 20 && $y < $starty + [winfo height $parent]} {
940    set startx [winfo rootx $parent]
941    if {$x > $startx - 20 && $x < $startx + [winfo width $parent]} {
942      set ToolbarSpecifications(AfterID) [after 400 "catch \
943      \"$parent configure -relief $::toolbar::DefaultOption(ToolbarFrameRelief)
944        destroy $win\""]
945      $parent configure -relief sunken
946      $win configure -background $DefaultOption(SelectBackground)
947      foreach obj [winfo children $win] {
948        if {[string equal [winfo class $obj] Button]} {
949          catch {$obj configure -background $DefaultOption(SelectBackground) \
950                       -highlightbackground $DefaultOption(SelectBackground)}
951        }
952      }
953      bind $win <FocusIn> \
954       "$parent configure -relief $::toolbar::DefaultOption(ToolbarFrameRelief);destroy %W"
955      return
956    }
957  }
958  bind $win <FocusIn> {}
959  $parent configure -relief $DefaultOption(ToolbarFrameRelief)
960  $win configure -background $DefaultOption(ToolbarBackground)
961  foreach obj [winfo children $win] {
962    if {[string equal [winfo class $obj] Button]} {
963      catch {$obj configure -background $DefaultOption(ToolbarBackground) \
964                   -highlightbackground $DefaultOption(ToolbarBackground)}
965    }
966  }
967};# ::toolbar::MountFloat
968
969
970#
971# Toolbar Handle Callback
972#
973#/////////////////////////////////////////////////////////////////////////////
974proc ::toolbar::GetCommandList {type args} {
975#
976# PURPOSE: Crea la lista de comandos a seleccionar por el usuario al crear
977#          un nuevo botón desde Tolbase
978#/////////////////////////////////////////////////////////////////////////////
979  variable widget
980  variable data
981 
982  set lst {}
983 
984  puts "type -> $type"
985  switch $type {
986    "prj" {
987      if {[llength $data(toolbar,prj,lstcmd)]} {
988        set lst $data(toolbar,prj,lstcmd)
989      }
990    }
991    "sadd" {
992      if {[llength $data(toolbar,sadd,lstcmd)]} {
993        set lst $data(toolbar,sadd,lstcmd)
994      }
995    }
996    "tolbase" {
997      if {[llength $data(toolbar,tolbase,lstcmd)]} {
998        set lst $data(toolbar,tolbase,lstcmd)
999      }
1000    }
1001  }
1002 
1003  puts "lista de valores -> $lst"
1004  return $lst
1005}
1006
1007proc ::toolbar::HandleCallback {toolbar {event 1} { type none} } {
1008  variable ToolbarSpecifications
1009 
1010  #Utilizo el evento 40 en caso de que los 39 anteriores ya esten ocupados...
1011  #pedro
1012  #Toolbar Wizzard
1013 
1014  if {$event == 40} {
1015    # creo la lista de formularios a elegir
1016    set cmdlista [::toolbar::GetCommandList $type]
1017    ::newButtonDiag2::Show \
1018      -toolbar $toolbar \
1019      -cmdlst  $cmdlista
1020   
1021    return
1022  } 
1023  if {$event == 1 && !$ToolbarSpecifications(FloatToolbar:$toolbar)} {return}
1024  if {$event > 0} {
1025    if {![string match $toolbar.handle* \
1026      [winfo containing [winfo pointerx $toolbar] [winfo pointery $toolbar]]]} \
1027      return
1028  } else {
1029    set event [expr abs($event)]
1030  }
1031  pack forget $toolbar.handle $toolbar.widgets
1032  $toolbar configure -height 1 -width 1 -bd 0
1033  if {$event < 2} {
1034    CreateToolbarWindow $toolbar
1035  }
1036  event generate $toolbar <<ToolBarHide>>
1037};# ::toolbar::HandleCallback
1038
1039#
1040# Toolbar Context Sensitive Menu
1041#
1042proc ::toolbar::ContextSensitiveMenu {toolbar} {
1043  variable ToolbarSpecifications
1044  package require msgcat
1045 
1046  set menu $toolbar.contextMenu
1047  catch {destroy $menu}
1048  menu $menu -tearoff 0
1049 
1050  set mbut [menu $menu.mbut -tearoff 0]
1051
1052
1053  #Primera Opcion
1054  if {$ToolbarSpecifications(HideToolbar:$toolbar)} {
1055    set butMen [$menu add cascade -label [::msgcat::mc "Nuevo Boton"] \
1056      -menu $mbut]
1057  }
1058 
1059  #SUBMENU BOTONES
1060  $mbut add command -label [mc "Boton TolBase"] \
1061    -command [list ::toolbar::HandleCallback $toolbar 40 "tolbase"]
1062 
1063  $mbut add command -label [mc "Boton SADD"] \
1064    -command [list ::toolbar::HandleCallback $toolbar 40 "sadd"]
1065 
1066  $mbut add command -label [mc "Boton Proyecto"] \
1067    -command [list ::toolbar::HandleCallback $toolbar 40 "prj"]
1068 
1069   
1070  #Segunda Opcion
1071  set parent [winfo parent $toolbar]
1072   if {$ToolbarSpecifications(HideToolbar:$toolbar)} {
1073    $menu add command -label [::msgcat::mc "Nueva Toolbar"] -command \
1074        "::newToolbarDiag::Show \
1075          -toolbartype \"toolbar\" \
1076          -toolbarparent $parent"
1077  }
1078  if {$ToolbarSpecifications(HideToolbar:$toolbar)} {
1079    $menu add command -label [::msgcat::mc "Nuevo Frame de Toolbars"] -command \
1080        "::newToolbarDiag::Show \
1081          -toolbartype \"toolbarframe\""
1082  }
1083  if {$ToolbarSpecifications(FloatToolbar:$toolbar)} {
1084    $menu add command -label [::msgcat::mc Desatar] -command \
1085        "::toolbar::HandleCallback $toolbar -1"
1086  }
1087  #if {$ToolbarSpecifications(HideToolbar:$toolbar)} {
1088  #  $menu add command -label [::msgcat::mc Ocultar] -command \
1089  #      "::toolbar::HandleCallback $toolbar -2"
1090  #}
1091 
1092 
1093  tk_popup $menu [winfo pointerx .] [winfo pointery .]
1094};# ::toolbar::ContextSensitiveMenu
1095
1096
1097## Click
1098#  Handler when the user clicks on the toolbar frame...
1099proc ::toolbar::Click {frame} {
1100  variable ToolbarSpecifications
1101  set parent [winfo parent $frame]
1102  set ToolbarSpecifications(X1:$frame) [expr {[winfo rootx $parent]+20}]
1103  set ToolbarSpecifications(Y1:$frame) [expr {[winfo rooty $parent]+20}]
1104  set ToolbarSpecifications(X2:$frame) \
1105    [expr {$ToolbarSpecifications(X1:$frame)+[winfo width  $parent]-40}]
1106  set ToolbarSpecifications(Y2:$frame) \
1107    [expr {$ToolbarSpecifications(X1:$frame)+[winfo height $parent]-40}]
1108};# Click
1109
1110proc ::toolbar::Motion {frame iPx iPy} {
1111  variable ToolbarSpecifications
1112  ## Get the first child of the parent...
1113  set parent [winfo parent $frame]
1114  set sFirst [lindex [pack slaves $parent] 0]
1115  if {![info exists ToolbarSpecifications(X1:$frame)]} {return}
1116  set cleanUp 0
1117  if {$iPx < $ToolbarSpecifications(X1:$frame) &&
1118      $ToolbarSpecifications(Side:$frame) != "left"} {
1119    set ToolbarSpecifications(Side:$frame) left
1120    SetOrientation $frame V
1121    if {[string length $sFirst]} {
1122      pack $frame -side left -fill y -before $sFirst
1123    } else {
1124      pack $frame -side left -fill y
1125    }
1126    ## Is there a decoration?
1127    if {[winfo exists $frame.toolbar_bottom_decoration]} {
1128      pack $frame.toolbar_bottom_decoration -side right -fill y \
1129             -expand 1 -pady 0 -ipady 0
1130    }
1131    set cleanUp 1
1132  } elseif {$iPx > $ToolbarSpecifications(X2:$frame) &&
1133            $ToolbarSpecifications(Side:$frame) != "right" } {
1134    set ToolbarSpecifications(Side:$frame) right
1135    SetOrientation $frame V
1136    if {[string length $sFirst]} {
1137      pack $frame -side right -fill y -before $sFirst
1138    } else {
1139      pack $frame -side right -fill y
1140    }
1141    ## Is there a decoration?
1142    if {[winfo exists $frame.toolbar_bottom_decoration]} {
1143      pack $frame.toolbar_bottom_decoration -side right -fill y \
1144             -expand 1 -pady 0 -ipady 0
1145    }
1146    set cleanUp 1
1147  } elseif {$iPy < $ToolbarSpecifications(Y1:$frame) &&
1148            $ToolbarSpecifications(Side:$frame) != "top"} {
1149    set ToolbarSpecifications(Side:$frame) top
1150    SetOrientation $frame H
1151    if {[string length $sFirst]} {
1152      pack $frame -side top -fill x -before $sFirst
1153    } else {
1154      pack $frame -side top -fill x
1155    }
1156    ## Is there a decoration?
1157    if {[winfo exists $frame.toolbar_bottom_decoration]} {
1158      pack $frame.toolbar_bottom_decoration -side bottom -fill x \
1159             -expand 1 -pady 0 -ipady 0
1160    }
1161    set cleanUp 1
1162  } elseif {$iPy > $ToolbarSpecifications(Y2:$frame) &&
1163            $ToolbarSpecifications(Side:$frame) != "bottom"} {
1164    set ToolbarSpecifications(Side:$frame) bottom
1165    SetOrientation $frame H
1166    if {[string length $sFirst]} {
1167      pack $frame -side bottom -fill x -before $sFirst
1168    } else {
1169      pack $frame -side bottom -fill x
1170    }
1171    ## Is there a decoration?
1172    if {[winfo exists $frame.toolbar_bottom_decoration]} {
1173      pack $frame.toolbar_bottom_decoration -side bottom -fill x \
1174             -expand 1 -pady 0 -ipady 0
1175    }
1176    set cleanUp 1
1177  }
1178  if {$cleanUp} {
1179    array unset ToolbarSpecifications X1:*
1180    array unset ToolbarSpecifications X2:*
1181    array unset ToolbarSpecifications Y1:*
1182    array unset ToolbarSpecifications Y2:*
1183  }
1184};# Motion
1185
1186
1187# ::toolbar::Tooltip --
1188#
1189#        This function will execute various tooltip-related tasks, like
1190#        displaying or destroying a tooltip window. This is an internal
1191#        function and should never be called by users...
1192#
1193# Arguments:
1194#        mode       One of "show" "cancel" "window".
1195#        widget     The widget under which the tooltip should be shown.
1196#        toolbar    The toolbar that holds the widget.
1197#
1198# Results:
1199#        Depends on mode...
1200proc ::toolbar::Tooltip {mode widget toolbar} {
1201  variable ToolbarSpecifications
1202  variable DefaultOption
1203 
1204  ## Has this widget a tooltip?
1205  if {![info exists ToolbarSpecifications(TooltipVar:$widget:$toolbar)] &&
1206      ![info exists ToolbarSpecifications(Tooltip:$widget:$toolbar)]} {return}
1207
1208  ## Has application lost the focus?
1209  set focus [focus]
1210  if {![string length $focus]} {
1211    set mode cancel
1212  } else {
1213    ## Is the focus still in the same toplevel?
1214    if {![string equal [winfo toplevel $widget] [winfo toplevel $focus]]} {
1215      set mode cancel
1216    }
1217  }
1218
1219  ## Is the mouse still in the same screen as the widget?
1220  foreach {mx my} [winfo pointerxy $widget] {break}
1221  if {$mx < 0 || $my < 0} {set mode cancel}
1222 
1223  ## Is the mouse still in the widget?
1224  set rootx [winfo rootx $widget]; set rooty [winfo rooty $widget]
1225  if {$mx < $rootx || $my < $rooty} {set mode cancel}
1226  if {$mx > $rootx+[winfo width $widget]||$my > $rooty+[winfo height $widget]} {
1227    set mode cancel
1228  }
1229
1230  switch $mode {
1231    show {
1232      ## We should register an event for showing the window...
1233      catch {after cancel $DefaultOption(TooltipAfterId)}
1234      catch {after cancel $DefaultOption(TooltipDestroyAfterId)}
1235      set DefaultOption(TooltipAfterId) [after $DefaultOption(TooltipDelay) \
1236        "::toolbar::Tooltip window $widget $toolbar"]
1237      ## If is a registered toolbar widget or variable, save the current value
1238      ## and place the tooltip...
1239      if {[info exists ToolbarSpecifications(StatusWidget:$widget:$toolbar)] ||
1240          [info exists ToolbarSpecifications(StatusVar:$widget:$toolbar)]} {
1241        if {[info exists ToolbarSpecifications(TooltipVar:$widget:$toolbar)]} {
1242          set message [set $ToolbarSpecifications(TooltipVar:$widget:$toolbar)]
1243        } else {
1244          set message $ToolbarSpecifications(Tooltip:$widget:$toolbar)
1245        }
1246        if {[info exists ToolbarSpecifications(StatusWidget:$widget:$toolbar)]} {
1247          set ToolbarSpecifications(StatusPrev:$widget:$toolbar) \
1248            [$ToolbarSpecifications(StatusWidget:$widget:$toolbar) cget -text]
1249          $ToolbarSpecifications(StatusWidget:$widget:$toolbar) configure \
1250            -text $message
1251        } else {
1252          set ToolbarSpecifications(StatusPrev:$widget:$toolbar) \
1253            [set $ToolbarSpecifications(StatusVar:$widget:$toolbar)]
1254          set ToolbarSpecifications(StatusVar:$widget:$toolbar) $message
1255        }
1256      }
1257    }
1258    cancel {
1259      ## Unregister any after events and destroy any window...
1260      catch {after cancel $DefaultOption(TooltipAfterId)}
1261      catch {after cancel $DefaultOption(TooltipDestroyAfterId)}
1262      catch {destroy .__tooltipWindow__hopeItsUnique}
1263      ## If is a registered status widget or variable, restore the original
1264      ## contents...
1265      if {[info exists ToolbarSpecifications(StatusWidget:$widget:$toolbar)] ||
1266          [info exists ToolbarSpecifications(StatusVar:$widget:$toolbar)]} {
1267        ## Get the message, in orderto compare it with the current contents...
1268        if {[info exists ToolbarSpecifications(TooltipVar:$widget:$toolbar)]} {
1269          set message [set $ToolbarSpecifications(TooltipVar:$widget:$toolbar)]
1270        } else {
1271          set message $ToolbarSpecifications(Tooltip:$widget:$toolbar)
1272        }
1273        ## Get what the status bar now shows...
1274        if {[info exists ToolbarSpecifications(StatusWidget:$widget:$toolbar)]} {
1275          set showing \
1276            [$ToolbarSpecifications(StatusWidget:$widget:$toolbar) cget -text]
1277        } else {
1278          set showing [set $ToolbarSpecifications(StatusVar:$widget:$toolbar)]
1279        }
1280        ## If what is now displaying in the status bar is equal to what we
1281        ## have place, restore it. Else, forget it, as something else has
1282        ## changed the status bar text...
1283        if {[string equal $message $showing]} {
1284          if {[info exists ToolbarSpecifications(StatusWidget:$widget:$toolbar)]} {
1285            $ToolbarSpecifications(StatusWidget:$widget:$toolbar) configure \
1286               -text $ToolbarSpecifications(StatusPrev:$widget:$toolbar)
1287          } else {
1288            set $ToolbarSpecifications(StatusVar:$widget:$toolbar) \
1289               $ToolbarSpecifications(StatusPrev:$widget:$toolbar)
1290          }
1291        }
1292        ## Catch is needed here: If the mouse stays too long in a widget, the
1293        ## status bar is resetted and this variable is gone. So, in the next
1294        ## <Leave> event we are called to free it again... (-nocomplain would
1295        ## also do the job here...)
1296        catch {unset ToolbarSpecifications(StatusPrev:$widget:$toolbar)}
1297      }
1298    }
1299    window {
1300      ## We should display a tooltip window...
1301      set win .__tooltipWindow__hopeItsUnique
1302      if {[info exists ToolbarSpecifications(TooltipVar:$widget:$toolbar)]} {
1303        set message [set $ToolbarSpecifications(TooltipVar:$widget:$toolbar)]
1304      } else {
1305        set message $ToolbarSpecifications(Tooltip:$widget:$toolbar)
1306      }
1307      set x [expr {[winfo rootx $widget] + ([winfo width $widget]/2)}]
1308      set y [expr {[winfo rooty $widget] + [winfo height $widget] + 4}]
1309      catch {destroy $win}
1310      toplevel $win -bg $DefaultOption(TooltipBackground) -highlightthickness 1\
1311        -highlightbackground $DefaultOption(TooltipForeground) \
1312        -highlightcolor $DefaultOption(TooltipForeground)
1313      wm overrideredirect $win 1
1314      bind $win <Leave> "destroy $win"
1315      label $win.l -text $message -relief flat -wraplength 265 \
1316        -bg $DefaultOption(TooltipBackground) -padx 2 -pady 0 \
1317        -fg $DefaultOption(TooltipForeground) -anchor w
1318      pack $win.l -side left -padx 0 -pady 0 -fill both -expand 1
1319      wm geometry $win +$x+$y
1320      set DefaultOption(TooltipDestroyAfterId) \
1321        [after 8000 "::toolbar::Tooltip cancel $widget $toolbar"]
1322    }
1323    default {}
1324  }
1325};# ::toolbar::Tooltip
1326
1327
1328# ::toolbar::Init --
1329#
1330#        Initialises the toolbar package...
1331#
1332# Arguments:
1333#        none
1334#
1335# Results:
1336#        The array "DefaultOptions" is initialised
1337proc ::toolbar::Init {} {
1338  variable DefaultOption
1339  ## Create a widget in order to get the default background colour...
1340  set DefaultOption(ToolbarBackground)       [. cget -background]
1341  set DefaultOption(ToolbarHandleBackground) [. cget -background]
1342  set w [text .toolbarPackageTestWidgetForGettingDefaultColours__[pid]]
1343  set DefaultOption(SelectBackground)        [$w cget -selectbackground]
1344  destroy $w
1345 
1346  ## This option specifies whether toolbars use an image as their handler or
1347  ## not. If true, the images IToolbar & IToolbarVertical should already
1348  ## exist. If false, the default toolbar handler are two vertical (or
1349  ## horizontal) lines...
1350  set DefaultOption(ToolbarImageHandle) 0
1351 
1352  ## We register two new events. These events should be virual ones, i.e. they
1353  ## should never be send by the window manager...
1354  event add <<ToolBarHide>> ToolbarHide
1355  event add <<ToolBarShow>> ToolbarShow
1356 
1357  ## Finally, add aliases for the needed mouse events. Using these fake events
1358  ## we allow users to redefine them in anything they consider appropriate...
1359  event add <<TMotion_1>> <Button1-Motion>
1360  event add <<TMB_1>>     <ButtonPress-1>
1361  event add <<TMB_2>>     <ButtonPress-3>
1362
1363  ## Operating system specific options...
1364  switch $::tcl_platform(platform) {
1365    windows {
1366      array set DefaultOption \
1367       {ToolbarFrameRelief flat ToolbarRelief groove ToolbarHandleRelief flat
1368        ToolbarFrameReliefBorderWidth  0 ToolbarReliefBorderWidth 0
1369        ToolbarHandleReliefBorderWidth 1 ToolbarDecorate 1}
1370    }
1371    default {
1372      array set DefaultOption \
1373       {ToolbarFrameRelief raised ToolbarRelief flat ToolbarHandleRelief raised
1374        ToolbarFrameReliefBorderWidth  1 ToolbarReliefBorderWidth 0
1375        ToolbarHandleReliefBorderWidth 1 ToolbarDecorate 0}
1376    }
1377  }
1378
1379  ## Tooltip support...
1380  set DefaultOption(TooltipDelay)      700
1381  set DefaultOption(TooltipAfterId)    0
1382  set DefaultOption(TooltipBackground) #ffffaa
1383  set DefaultOption(TooltipForeground) black
1384};# ::toolbar::Init
1385## Initialise default values...
1386::toolbar::Init
1387
1388## Test our Toolbar package. Comment out for common use...
1389if {0} {
1390  package req msgcat
1391  ::msgcat::mclocale en
1392  image create photo timage -data \
1393{R0lGODlhEAAQAKUAAGRjZGJmZ1FQUYSChICFh2KdnyO6u1FlZ4GEhmGeoCO5
1394ugChogCChFFfYWGhoiK6uwCgoXw1NgDKy+RZWvcICKRfYQC8vepERf8AAPkG
1395BopiY8VERcUAANYAALQZGYR6fB16fABsbrAYGAO5um9xcgBUVUxCQwBiZABv
1396cElISWxrbHd1d0xKTIiGiAB2eBRaW01PUQB5exBVV2FwcQC5uglOT2FtbmJr
1397bf///////////////////////////////yH+Dk1hZGUgd2l0aCBHSU1QACH5
1398BAEKADgALAAAAAAQABAAAAZxQJxwCCgaAYGhUjBoNgkFw0EpZDYRCcWC0aDi
1399rI4HhEHuUiNNCXltHk4olYFlXR5eMPiMZk5vbzgdGB4fFiAhbF4iHwMjJCWI
1400VCZNFicokEopKit8l0MsOC2cdV5CnC4vMKSlDDEyM6pDNDU2sEo3pEEAOw==}
1401
1402  ## Create a status bar...
1403  label .status -text {This is a status bar...} -relief sunken -bd 1 \
1404    -anchor w
1405  pack .status -fill x -side bottom -padx 0 -pady 0
1406
1407  ## 1) Create a horizontal toolbar frame...
1408  set TF [::toolbar::ToolbarFrame .toolbarFrame]
1409    ## 2) Create a toolbar in this toolbar frame...
1410    set tb1 [::toolbar::create $TF.tb1]
1411    ## 3) Add some buttons/widgets in this toolbar...
1412    ::toolbar::addwidget $tb1 label -text {T 1} -bd 0 -bg red -fg white \
1413      -tooltip {T 1} -statuswidget .status
1414    ::toolbar::addbutton $tb1 -image timage -statuswidget .status \
1415      -tooltip {Button 1} -command {Command {Button 1}}
1416    ::toolbar::addbutton $tb1 -image timage -statuswidget .status \
1417      -tooltip {Button 2} -command {Command {Button 2}}
1418    ::toolbar::addbutton $tb1 -image timage -statuswidget .status \
1419      -tooltip {Button 3} -command {Command {Button 3}}
1420    ::toolbar::addseparator $tb1
1421    ::toolbar::addwidget $tb1 label -text {Exit :} -bd 0 -tooltip Exit... \
1422      -statuswidget .status
1423    ::toolbar::addbutton $tb1 -image timage  \
1424      -tooltip {Exit} -command {exit} -statuswidget .status
1425    ## 4) Pack the toolbar inside the toolbar frame...
1426    pack $tb1 -side left -fill y
1427
1428    ## Create a second toolbar in this toolbar frame...
1429    set tb2 [::toolbar::create $TF.tb2]
1430    ## 3) Add some buttons/widgets in this toolbar...
1431    ::toolbar::addwidget $tb2 label -text {T 3} -bd 0 -bg orange -fg white \
1432      -tooltip {T 3} -statuswidget .status
1433    ::toolbar::addwidget $tb2 label -text {Type Here:} -bd 0 \
1434      -tooltip {The next is an entry widget. You can type there...} \
1435      -statuswidget .status
1436    ::toolbar::addwidget $tb2 entry -width 5 -relief sunken -bg white -fg navy\
1437      -tooltip {This is an entry widget. You can type here...} \
1438      -statuswidget .status
1439    ::toolbar::addwidget $tb2 spinbox -width 2 -relief sunken -bg white \
1440      -fg navy -tooltip {This is a spinbox widget!} -from 0 -to 20 \
1441      -statuswidget .status
1442    set mb [::toolbar::addwidget $tb2 menubutton -text {File} -indicatoron 0 \
1443      -tooltip {This is a menubutton widget!} -statuswidget .status]
1444    menu $mb.menu -tearoff 0
1445    $mb.menu add command -label Exit -command exit
1446    $mb configure -menu $mb.menu
1447    ::toolbar::addwidget $tb2 checkbutton -text Select \
1448      -tooltip {This is a checkbutton widget. You can select it...} \
1449      -statuswidget .status
1450    ## Pack the toolbar inside the toolbar frame...
1451    pack $tb2 -side left -fill y
1452  ## 5) Pack the toolbar frame in our window...
1453  pack $TF -side top -fill x
1454
1455  ## Create a vertical toolbar frame...
1456  set VTF [::toolbar::ToolbarFrame .vtoolbarFrame -orientation vertical]
1457  ## Create a toolbar in this toolbar frame...
1458    set tbv1 [::toolbar::create $VTF.tbv1]
1459    ## Add some buttons/widgets in this toolbar...
1460    ::toolbar::addwidget $tbv1 label -text {T 2} -bd 0 -bg blue -fg white \
1461      -tooltip {T 2} -statuswidget .status
1462    ::toolbar::addbutton $tbv1 -image timage -statuswidget .status \
1463      -tooltip {Button 1} -command {Command {Button 1}}
1464    ::toolbar::addbutton $tbv1 -image timage -statuswidget .status \
1465      -tooltip {Button 2} -command {Command {Button 2}}
1466    ::toolbar::addbutton $tbv1 -image timage -statuswidget .status \
1467      -tooltip {Button 3} -command {Command {Button 3}}
1468    ::toolbar::addseparator $tbv1
1469    ::toolbar::addwidget $tbv1 entry -width 5 -relief sunken \
1470      -bg white -fg navy -tooltip {You can type in here!} \
1471      -statuswidget .status
1472    ::toolbar::addseparator $tbv1
1473    ::toolbar::addwidget $tbv1 label -text {Exit :} -bd 0 -tooltip Exit... \
1474      -statuswidget .status
1475    ::toolbar::addbutton $tbv1 -image timage  \
1476      -tooltip {Exit} -command {exit} -statuswidget .status
1477    ## Pack the toolbar inside the toolbar frame...
1478    pack $tbv1 -side left -fill y
1479  ## Pack the toolbar frame in our window...
1480  pack $VTF -side left -fill y
1481
1482  ## Add an area with some buttons that do various ops over the toolbars...
1483  frame .area
1484    button .area.act1  -text {Activate 1} -bg red -fg white -command \
1485      "::toolbar::activate $tb1"
1486    button .area.dact1 -text {Deactivate 1} -bg red -fg white -command \
1487      "::toolbar::deactivate $tb1"
1488    button .area.act2  -text {Activate 2} -bg blue -fg white -command \
1489      "::toolbar::activate $tbv1"
1490    button .area.dact2 -text {Deactivate 2} -bg blue -fg white -command \
1491      "::toolbar::deactivate $tbv1"
1492    button .area.act3  -text {Activate 3} -bg orange -fg white -command \
1493      "::toolbar::activate $tb2"
1494    button .area.dact3 -text {Deactivate 3} -bg orange -fg white -command \
1495      "::toolbar::deactivate $tb2"
1496    grid .area.act1 .area.dact1 .area.act2 .area.dact2 .area.act3 .area.dact3 \
1497      -padx 2 -pady 2 -sticky snew
1498    button .area.shw1  -text {Show 1} -bg red -fg white -command \
1499      "::toolbar::deiconify $tb1"
1500    button .area.hide1 -text {Hide 1} -bg red -fg white -command \
1501      "::toolbar::HandleCallback $tb1 -2"
1502    button .area.shw2  -text {Show 2} -bg blue -fg white -command \
1503      "::toolbar::deiconify $tbv1"
1504    button .area.hide2 -text {Hide 2} -bg blue -fg white -command \
1505      "::toolbar::HandleCallback $tbv1 -2"
1506    button .area.shw3  -text {Show 3} -bg orange -fg white -command \
1507      "::toolbar::deiconify $tb2"
1508    button .area.hide3 -text {Hide 3} -bg orange -fg white -command \
1509      "::toolbar::HandleCallback $tb2 -2"
1510    grid .area.shw1 .area.hide1 .area.shw2 .area.hide2 .area.shw3 .area.hide3 \
1511      -padx 2 -pady 2 -sticky snew
1512    button .area.flt1  -text {Float 1} -bg red -fg white -command \
1513      "::toolbar::HandleCallback $tb1 -1"
1514    button .area.mnt1 -text {Mount 1} -bg red -fg white -command \
1515      "catch \"destroy $tb1.fltWin\""
1516    button .area.flt2  -text {Float 2} -bg blue -fg white -command \
1517      "::toolbar::HandleCallback $tbv1 -1"
1518    button .area.mnt2 -text {Mount 2} -bg blue -fg white -command \
1519      "catch \"destroy $tbv1.fltWin\""
1520    button .area.flt3  -text {Float 3} -bg orange -fg white -command \
1521      "::toolbar::HandleCallback $tb2 -1"
1522    button .area.mnt3 -text {Mount 3} -bg orange -fg white -command \
1523      "catch \"destroy $tb2.fltWin\""
1524    grid .area.flt1 .area.mnt1 .area.flt2 .area.mnt2 .area.flt3 .area.mnt3 \
1525      -padx 2 -pady 2 -sticky snew
1526    button .area.print -text {Print Variables} -command \
1527    {catch {console show};puts \n\n###########################\n
1528     parray ::toolbar::ToolbarSpecifications}
1529    grid .area.print -columnspan 6 -padx 2 -pady 2 -sticky snew
1530  pack .area -fill both -expand 1
1531 
1532  proc Command {message} {
1533    tk_messageBox -icon info -title Info: -type ok -message $message
1534  }
1535
1536  wm geometry . 800x400
1537  focus .
1538}
1539
1540
1541
1542
Note: See TracBrowser for help on using the repository browser.