9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
|
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
|
-
+
+
+
+
+
+
+
+
+
+
+
+
|
# Permission is granted to use this code under the same terms as
# for the Tcl core code.
#
#----------------------------------------------------------------------
# $Revision: 1.1 $
#----------------------------------------------------------------------
package provide psballoon 1.1
package provide psballoon 1.2
namespace eval psballoon {
variable balloon
variable config
set config(-useframe) 0
set balloon(W) ""
set balloon(pending) 0
set balloon(created) 0
set balloon(id) ""
namespace export addBalloon
}
# -useframe <bool>
proc psballoon::configure {args} {
variable config
foreach {arg val} $args {
set config($arg) $val
}
}
# Do some simple formatting, to be able to have cleaner text in source
proc psballoon::Fmt {msg} {
# Remove any newlines.
set msg [regsub -all "\n" $msg " "]
# Remove multiple whitespace
set msg [regsub -all {\s+} $msg " "]
|
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
|
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
|
+
+
+
+
+
-
+
+
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
}
lappend lines $line
}
set msg [join $lines \n]
return $msg
}
# addBalloon widget ?widgets...? ?-fmt? ?msg?
# If message is not given, it is extracted from widget. This is used to show
# e.g. labels where text might not be fully visible.
# Message may contain callbacks in [] for dynamic text.
proc psballoon::addBalloon {W args} {
variable balloon
# Last argument is message
set msg [lindex $args end]
set args [lrange $args 0 end-1]
# Request for formatting
if {"-fmt" in $args && $msg ne ""} {
set msg [Fmt $msg]
}
# Request for formatting
if {$arg eq "-fmt"} {
if {$msg ne ""} {
set msg [Fmt $msg]
}
} else {
lappend Wlist $arg
}
}
foreach W $Wlist {
AddBalloon2 $W $msg
}
}
proc psballoon::AddBalloon2 {W msg} {
variable balloon
set c [winfo class $W]
if {$msg == "" && $c != "Listbox" && $c != "Label"} {
error "Missing message to balloon for $W ($c)"
}
set balloon(msg,$W) $msg
bind $W <Enter> {
|
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
-
-
+
+
|
}
proc psballoon::killBalloon {} {
variable balloon
if {$balloon(pending) == 1} {
after cancel $balloon(id)
}
if {[winfo exists .balloon] == 1} {
destroy .balloon
if {[winfo exists $balloon(W)]} {
destroy $balloon(W)
}
set balloon(created) 0
set balloon(pending) 0
}
# Measure display width needed for a text with line breaks
proc psballoon::Measure {font txt} {
|
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
|
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
|
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
|
# is one more screen to the right
if {$maxX > $sW} {
lappend screens $sW $maxX
}
return $screens
}
proc psballoon::createBalloon {W mx my} {
proc psballoon::createBalloon {W mouseX mouseY} {
variable balloon
variable config
if { ! [winfo exists $W]} {
return
}
if {$balloon(created) == 0} {
# Figure out widget's font
if {[catch {set font [$W cget -font]}]} {
set font [ttk::style lookup [winfo class $W] -font]
}
# Fallback to something reasonable if font fails.
if {$font eq ""} {
set font TkDefaultFont
}
set ww [winfo width $W]
set ih [winfo height $W]
if {[winfo class $W] in {TLabelframe Labelframe}} {
# Put it below the label, not the entire widget.
# 1.5 font heights is a reasonable guess
set fh [font metrics $font -linespace]
set ih [expr {$fh * 3 /2 }]
# Below cursor at least
if {$ih <= $my} {
set ih [expr {$my + 5}]
}
}
set ix 0
set iy 0
set create 1
set msg $balloon(msg,$W)
if {$msg == ""} {
switch [winfo class $W] {
Listbox {
set i [$W index @$mx,$my]
set msg [$W get $i]
foreach {ix iy iw ih} [$W bbox $i] {break}
}
Label {
set msg [$W cget -text]
set iw [Measure $font $msg]
}
}
# Don't create a balloon if the text is fully visible.
set create [expr {$iw > $ww - 8}]
} else {
if {[string index $msg 0] eq "\["} {
set msg [subst -novariables -nobackslashes $msg]
}
set iw [Measure $font $msg]
}
if {$create} {
set x [expr {[winfo rootx $W] + $ix}]
set y [expr {[winfo rooty $W] + $iy + $ih + 2}]
if {$balloon(created)} {
return
}
# Figure out widget's font
if {[catch {set font [$W cget -font]}]} {
set font [ttk::style lookup [winfo class $W] -font]
}
# Fallback to something reasonable if font fails.
if {$font eq ""} {
set font TkDefaultFont
}
set wWidth [winfo width $W]
set wHeight [winfo height $W]
if {[winfo class $W] in {TLabelframe Labelframe}} {
# Put it below the label, not the entire widget.
# 1.5 font heights is a reasonable guess
set fontHeight [font metrics $font -linespace]
set wHeight [expr {$fontHeight * 3 /2 }]
# Below cursor at least
if {$wHeight <= $mouseY} {
set wHeight [expr {$mouseY + 5}]
}
}
set ix 0
set iy 0
set create 1
set msg $balloon(msg,$W)
if {$msg == ""} {
# Extract text from widget
switch [winfo class $W] {
Listbox {
set i [$W index @$mouseX,$mouseY]
set msg [$W get $i]
foreach {ix iy iw wHeight} [$W bbox $i] {break}
}
Label {
set msg [$W cget -text]
set iw [Measure $font $msg]
}
}
# Don't create a balloon if the text is fully visible.
set create [expr {$iw > $wWidth - 8}]
} else {
if {[string index $msg 0] eq "\["} {
set msg [subst -novariables -nobackslashes $msg]
}
set iw [Measure $font $msg]
}
if {$create} {
# Preferred position of the balloon
set rootX [expr {[winfo rootx $W] + $ix}]
set rootY [expr {[winfo rooty $W] + $iy + $wHeight + 2}]
if {$config(-useframe)} {
set top [winfo toplevel $W]
set posX [expr {$rootX - [winfo rootx $top]}]
set posY [expr {$rootY - [winfo rooty $top]}]
set minX 6
set maxX [expr {[winfo width $top] - 6}]
} else {
set posX $rootX
set posY $rootY
# Limits of current screen.
foreach {minX maxX} [FigureOutScreenWidths $W] {
if {$minX <= $x && $x < $maxX} break
if {$minX <= $rootX && $rootX < $maxX} break
}
# Move it to the left as needed to fit on screen
if {$x + $iw + 8 > $maxX} {
set x [expr {$maxX - $iw - 8}]
}
# TBD, option to use a frame in parent instead?
toplevel .balloon -bg black
wm overrideredirect .balloon 1
label .balloon.l \
-text $msg -relief flat -font $font -justify left \
-bg #ffffaa -fg black -padx 2 -pady 0 -anchor "w"
pack .balloon.l -side left -padx 1 -pady 1
wm geometry .balloon +${x}+${y}
set balloon(created) 1
}
}
}
# Move it to the left as needed to fit on screen
if {$posX + $iw + 8 > $maxX} {
set posX [expr {$maxX - $iw - 8}]
}
if {$config(-useframe)} {
if {$top eq "."} {
set B .balloon
} else {
set B $top.balloon
}
frame $B -borderwidth 1 -relief solid
} else {
set B .balloon
toplevel $B -bg black
wm overrideredirect $B 1
}
label $B.l \
-text $msg -relief flat -font $font -justify left \
-bg #ffffaa -fg black -padx 2 -pady 0 -anchor "w"
pack $B.l -side left -padx 1 -pady 1
if {$config(-useframe)} {
place $B -x $posX -y $posY -anchor nw
} else {
wm geometry .balloon +${posX}+${posY}
}
set balloon(W) $B
set balloon(created) 1
}
}
}
|