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
119
120
121
122
123
124
125
126
127
128
|
# 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: colorlab.tcl,v 1.13 2005/01/02 00:45:07 jfontain Exp $
class colorLabels {
proc colorLabels {this parentPath args} composite {[::new frame $parentPath] $args} {
set ($this,labels) {}
composite::complete $this
}
proc ~colorLabels {this} {
eval ::delete $($this,labels)
}
proc options {this} {
return [list\
[list -colorheight 0 0]\
]
}
proc set-colorheight {this value} {
if {$composite::($this,complete)} {
error {option -colorheight cannot be set dynamically}
}
}
proc new {this popupMenu args} {
set label [eval ::new label $widget::($this,path) -colorheight $composite::($this,-colorheight) $args]
if {[string length $popupMenu] > 0} {
set command "set colorLabels::label::(clicked) $label; tk_popup $popupMenu %X %Y"
foreach path [concat $widget::($label,path) [winfo children $widget::($label,path)]] {
bind $path <ButtonPress-3> $command
}
}
lappend ($this,labels) $label
refresh $this
return $label
}
proc delete {this label} {
ldelete ($this,labels) $label
::delete $label
refresh $this
}
proc refresh {this} {
set path $widget::($this,path)
catch {eval grid forget [grid slaves $path]}
set row 0
foreach label $($this,labels) {
grid $widget::($label,path) -row $row -sticky new
incr row
grid rowconfigure $path $row -minsize 1 ;# insert a single pixel wide vertical separator area between labels
incr row
}
}
}
class colorLabels {
class label {
proc label {this parentPath args} composite {[new frame $parentPath] $args} {
set path $widget::($this,path)
# use color label width and text padding identical to pie box labeler
composite::manage $this [new frame $path -highlightbackground black -highlightthickness 1 -width 11] frame\
[new label $path -font $font::(mediumNormal) -anchor nw -justify left -padx 2] label
pack $composite::($this,frame,path) -side left
pack $composite::($this,label,path) -fill both -expand 1
composite::complete $this
}
proc ~label {this} {}
proc options {this} {
return [list\
[list -background {} {}]\
[list -color {} {}]\
[list -colorheight 0 0]\
[list -relief flat flat]\
[list -text {} {}]\
]
}
proc set-background {this value} {
if {[string length $value] == 0} {
set value $widget::option(label,background)
}
$composite::($this,label,path) configure -background $value
}
proc set-color {this value} {
$composite::($this,frame,path) configure -background $value
}
proc set-colorheight {this value} {
update $this
}
proc set-relief {this value} {
$composite::($this,label,path) configure -relief $value
}
proc set-text {this value} {
$composite::($this,label,path) configure -text $value
update $this
}
proc update {this} {
set height $composite::($this,-colorheight)
if {$height <= 0} {
set height [winfo reqheight $composite::($this,label,path)]
}
$composite::($this,frame,path) configure -height $height
}
proc height {this} { ;# valid anytime, otherwise an update is needed before frame container returns the correct height
return [winfo reqheight $composite::($this,label,path)]
}
}
}
|
