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
115
116
117
118
|
# copyright (C) 1997-2005 Jean-Luc Fontaine (mailto:jfontain@free.fr)
# this program is free software: please read the COPYRIGHT file enclosed in this package or use the Help Copyright menu
# $Id: imbutton.tcl,v 1.6 2005/01/02 00:45:07 jfontain Exp $
class imageButton {
proc imageButton {this parentPath args} composite {[new frame $parentPath -borderwidth 1] $args} {
composite::manage $this [new label $widget::($this,path) -text ?] label
bind $widget::($this,path) <Leave> {%W configure -relief flat}
set path $composite::($this,label,path)
bind $path <Configure> "imageButton::update $this %w %h"
place $path -x 0 -y 0
composite::complete $this
}
proc ~imageButton {this} {
catch {image delete $($this,grayed)}
}
proc options {this} {
return [list\
[list -command {} {}]\
[list -disabledgray 0 0]\
[list -image {} {}]\
[list -state normal]\
]
}
proc set-command {this value} {}
proc set-disabledgray {this value} {} ;# whether image is processed to better looking gray tones in disabled state
proc set-image {this value} {
$composite::($this,label,path) configure -image $value
catch {image delete $($this,grayed); unset ($this,grayed)} ;# reset grayed image
}
proc set-state {this value} {
set path $widget::($this,path)
set label $composite::($this,label,path)
switch $value {
normal {
bind $path <Enter> {%W configure -relief raised}
bind $label <ButtonPress-1> "imageButton::action $this 1"
bind $label <ButtonRelease-1> "imageButton::action $this 0"
$label configure -image $composite::($this,-image)
}
disabled {
bind $path <Enter> {}
bind $label <ButtonPress-1> {}
bind $label <ButtonRelease-1> {}
if {$composite::($this,-disabledgray)} {
if {![info exists ($this,-grayed)]} {
set image $composite::($this,-image)
set ($this,-grayed)\
[image create photo -width [image width $image] -height [image height $image] -palette 256 -gamma 2]
$($this,-grayed) copy $image
}
$label configure -image $($this,-grayed)
}
}
default {
error "bad state value \"$value\": must be normal or disabled"
}
}
if {!$composite::($this,-disabledgray)} {
$label configure -state $value
}
}
proc update {this width height} { ;# 2 x 1 pixel border + 1 pixel offset when shifting image
$widget::($this,path) configure -width [incr width 3] -height [incr height 3]
}
proc action {this pressed} {
if {$pressed} {
relief $this 1
set ($this,inside) 1
bind $composite::($this,label,path) <Motion> "imageButton::motion $this %X %Y"
} else {
relief $this 0
bind $composite::($this,label,path) <Motion> {}
if {$($this,inside) && ([string length $composite::($this,-command)] > 0)} {
uplevel #0 $composite::($this,-command) ;# always invoke command at global level
# in case a dialog box is opened on top of button in which case leave event is never seen:
after 1000 "$widget::($this,path) configure -relief flat"
}
}
}
proc motion {this X Y} { ;# when button is kept pressed, leave events do not occur, so track cursor here
set inside [string equal [winfo containing $X $Y] $composite::($this,label,path)]
if {$inside == $($this,inside)} return ;# no change
if {$inside} {
relief $this 1
} else {
relief $this 0
$widget::($this,path) configure -relief flat ;# emulate KDE buttons behavior
}
set ($this,inside) $inside
}
proc relief {this sunken} {
set label $composite::($this,label,path)
if {$sunken} {
$widget::($this,path) configure -relief sunken
place $label -x 1 -y 1 ;# shift to simulate sinking
$label configure -background $widget::option(button,activebackground)
} else {
$widget::($this,path) configure -relief raised
place $label -x 0 -y 0
$label configure -background $widget::option(button,background)
}
}
}
|
