20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
+
+
+
+
+
+
|
set balloon(pending) 0
set balloon(created) 0
set balloon(id) ""
namespace export addBalloon
}
# 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 " "]
set msg [string trim $msg]
# Any explicitly requested newlines?
set msg [regsub -all {\\n\s*} $msg "\n"]
# Further line breaks by length?
set lines {}
foreach line [split $msg \n] {
while {[string length $line] > 80} {
# There should be no path through this loop that does not
# shorten $line
set ix [string last " " $line 80]
if {$ix < 0} {
set ix [string first " " $line]
if {$ix < 0} {
# Just cut at 80
set ix 80
}
}
if {$ix == 0} {
set line [string trim $line]
} else {
lappend lines [string range $line 0 $ix-1]
set line [string range $line $ix+1 end]
}
}
lappend lines $line
}
set msg [join $lines \n]
return $msg
}
proc psballoon::addBalloon {w {msg ""}} {
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]
if {$msg == "" && $c != "Listbox" && $c != "Label"} {
error "Missing message to balloon for $w ($c)"
}
set balloon(msg,$w) $msg
bind $w <Enter> {
set ::psballoon::balloon(pending) 1
|
62
63
64
65
66
67
68
69
70
71
72
73
74
75
|
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
+
+
+
+
+
+
+
+
+
+
+
+
|
}
if {[winfo exists .balloon] == 1} {
destroy .balloon
}
set balloon(created) 0
set balloon(pending) 0
}
# Measure display width needed for a text with line breaks
proc psballoon::Measure {font txt} {
set len 0
foreach line [split $txt \n] {
set lw [font measure $font $line]
if {$lw > $len} {
set len $lw
}
}
return $len
}
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]
|
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
-
+
-
+
|
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 [font measure $font $msg]
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 [font measure $font $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}]
}
|