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
|
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
|
-
+
-
+
-
+
-
-
+
+
-
+
-
+
-
+
|
}
lappend lines $line
}
set msg [join $lines \n]
return $msg
}
proc psballoon::addBalloon {w args} {
proc psballoon::addBalloon {W args} {
variable balloon
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]
}
set c [winfo class $w]
set c [winfo class $W]
if {$msg == "" && $c != "Listbox" && $c != "Label"} {
error "Missing message to balloon for $w ($c)"
error "Missing message to balloon for $W ($c)"
}
set balloon(msg,$w) $msg
bind $w <Enter> {
set balloon(msg,$W) $msg
bind $W <Enter> {
set ::psballoon::balloon(pending) 1
set ::psballoon::balloon(created) 0
set ::psballoon::balloon(id) [after 500 {psballoon::createBalloon %W %x %y}]
}
bind $w <Button> {
bind $W <Button> {
psballoon::killBalloon
}
bind $w <Leave> {
bind $W <Leave> {
psballoon::killBalloon
}
bind $w <Motion> {
bind $W <Motion> {
if {$::psballoon::balloon(pending) == 1} {
after cancel $::psballoon::balloon(id)
}
if {$::psballoon::balloon(created) == 1} {
psballoon::killBalloon
}
set ::psballoon::balloon(id) [after 500 {psballoon::createBalloon %W %x %y}]
|
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
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
|
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
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
|
-
+
-
-
+
+
-
-
-
+
+
+
-
+
-
+
-
-
-
+
+
+
-
+
-
-
-
-
+
+
+
+
|
if {$lw > $len} {
set len $lw
}
}
return $len
}
proc psballoon::createBalloon {w mx my} {
proc psballoon::createBalloon {W mx my} {
variable balloon
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]
if {[catch {set font [$W cget -font]}]} {
set font [ttk::style lookup [winfo class $W] -font]
}
# Fallback to something reasonable of 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}} {
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)
set msg $balloon(msg,$W)
if {$msg == ""} {
switch [winfo class $w] {
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}
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 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 {$x + $iw + 8 > [winfo screenwidth $w]} {
set x [expr {[winfo screenwidth $w] - $iw - 8}]
set x [expr {[winfo rootx $W] + $ix}]
set y [expr {[winfo rooty $W] + $iy + $ih + 2}]
if {$x + $iw + 8 > [winfo screenwidth $W]} {
set x [expr {[winfo screenwidth $W] - $iw - 8}]
}
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
}
}
}
|