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
|
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
129
|
+
+
+
+
+
-
+
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
+
+
|
# 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
variable config
set frame $config(-useframe)
# Last argument is message
set msg [lindex $args end]
set Wlist [list $W]
foreach arg [lrange $args 0 end-1] {
switch $arg {
-fmt {
# Request for formatting
# Request for formatting
if {$arg eq "-fmt"} {
if {$msg ne ""} {
set msg [Fmt $msg]
}
} else {
lappend Wlist $arg
AddBalloon2 $W $msg
AddBalloon2 $W $msg $frame
}
}
proc psballoon::AddBalloon2 {W msg} {
proc psballoon::AddBalloon2 {W msg frame} {
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
set balloon(frame,$W) $frame
bind $W <Enter> {
set ::psballoon::balloon(pending) 1
set ::psballoon::balloon(created) 0
set ::psballoon::balloon(lastX) %X
set ::psballoon::balloon(lastY) %Y
set ::psballoon::balloon(id) [after 500 {psballoon::createBalloon %W %x %y}]
}
|
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
|
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
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
|
+
+
+
+
-
-
+
+
-
+
+
-
+
-
+
-
+
+
-
-
-
-
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
|
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
}
# Widget Geometry
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}]
}
}
# Item Geometry within Widget (if any)
set ix 0
set iy 0
set itemX 0
set itemY 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}
foreach {itemX itemY itemWidth wHeight} [$W bbox $i] {break}
set bWidth $itemWidth
}
Label {
set msg [$W cget -text]
set iw [Measure $font $msg]
set bWidth [Measure $font $msg]
}
}
# Don't create a balloon if the text is fully visible.
set create [expr {$iw > $wWidth - 8}]
set create [expr {$bWidth > $wWidth - 8}]
} else {
if {[string index $msg 0] eq "\["} {
set msg [subst -novariables -nobackslashes $msg]
}
set iw [Measure $font $msg]
set bWidth [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 {!$create} return
# Preferred position of the balloon
set rootX [expr {[winfo rootx $W] + $itemX}]
set rootY [expr {[winfo rooty $W] + $itemY + $wHeight + 2}]
set useframe $balloon(frame,$W)
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
if {$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 <= $rootX && $rootX < $maxX} break
}
}
# 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
if {$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 {$useframe} {
place $B -x $posX -y $posY -anchor nw
} else {
wm geometry $B +${posX}+${posY}
}
set balloon(W) $B
set balloon(created) 1
}
|