1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
|
#
# ButtonMenubutton
# act like a button for quick clicks
# act like a menu if hold down button
#
# 22 July 1997 by Tom Phelps (phelps@ACM.org),
# on top of Tk's button and menubutton bindings
#
# To use, create a menubutton and pass it and the command to execute
# if it's invoked as a button to the proc "buttonmenubutton"
#
# To convert to button-only operation,
# <widget-name> configure -menu ""
# To convert to menu-only operation,
# set bmb(<widget-name>) to ""
# If you save the former value, you can reverse these conversions
# by restoring the former values.
# If you disable the original menubutton, both button and menubutton
# behaviors are disabled.
# Namespace use:
# buttonmenubutton proc name
# bmb prefix for proc names
# bmb() array
# To do
# stash code in a namespace?
# seems to be some interference with vwait (as by alert box)
set bmb(menubutton-delay) 250
set bmb(type) ""
set bmb(after) ""
set bmb(relief) ""
set bmb(w) ""
set bmb(x) ""; set bmb(y) ""
#set bmb(<widget-name>) <button-command>
proc buttonmenubutton {mb {cmd ""}} {
global bmb
if {[winfo class $mb]!="Menubutton"} {error "$mb must be a menubutton"}
# store commands
set bmb($mb) $cmd
# on Button-1, assume it's a click, correct later according to timer
bind $mb <Button-1> {if [catch {bmbB1Down %W %X %Y}] break}
bind $mb <B1-Motion> {if {$bmb(type)=="button"} break}
bind $mb <ButtonRelease-1> {if [catch {bmbB1Up %W}] break}
}
proc bmbB1Down {w x y} {
global bmb tkPriv
# would be nice if break and continue could be thrown as exceptions
# to be recognized in bindings
if {$tkPriv(postedMb)!=""} {tkMbButtonUp $w; return -code break}
if {$bmb(type)!=""} {return -code break}
set bmb(w) $w; set bmb(relief) [$w cget -relief]
set bmb(x) $x; set bmb(y) $y
# if no command, treat as a menu straight away
if {$bmb($w)==""} {set bmb(type) ""; return}; # continue with menubutton bindings
# pretend you're a button at first
set bmb(type) "button"
tkButtonDown $w
# if have a menu, possibility of converting to menubutton operation
if {[$w cget -menu]!="" && [[$w cget -menu] index end]!="none"} {
set bmb(after) [after $bmb(menubutton-delay) bmbConvert]
}
return -code break
}
proc bmbB1Up {w} {
global bmb
if {$bmb(type)=="button"} {bmbButtonUp $w} else {tkMbButtonUp $w}
# clean up for button
set bmb(type) ""
if {$bmb(after)!=""} {after cancel $bmb(after)}
set bmb(after) ""
$bmb(w) configure -relief $bmb(relief)
return -code break
}
proc bmbConvert {} {
global bmb tkPriv
# if already finished as button, we're done
if {$bmb(type)==""} return
set tkPriv(buttonWindow) ""; # clean up
set bmb(after) ""
$bmb(w) configure -relief $bmb(relief)
set bmb(type) ""; # give control over to the menu system
set tkPriv(inMenubutton) $bmb(w)
tkMbPost $bmb(w) $bmb(x) $bmb(y)
$bmb(w) configure -relief sunken; # that's how Netscape does it
}
proc bmbButtonUp {w} {
global bmb tkPriv
if {$w == $tkPriv(buttonWindow)} {
set tkPriv(buttonWindow) ""
if {[$w cget -state]!="disabled"} {
uplevel #0 $bmb($w)
}
}
}
|
