1
2array set Balloon {
3  set 0
4  first 0
5  id ""
6}
7
8proc set_balloon {target message} {
9  global Balloon
10  set tags [bindtags $target]
11  set n [lsearch $tags Balloon]
12  if {$message == ""} {
13    if {$n >= 0} {
14      bindtags $target [lreplace $tags $n $n]
15    }
16  } else {
17    if {$n < 0} {
18      bindtags $target "Balloon $tags"
19    }
20  }
21  set Balloon($target) $message
22}
23
24proc end_balloon {target} {
25  set_balloon $target ""
26}
27
28bind Balloon <Enter> {
29  set Balloon(set) 0
30  set Balloon(first) 1
31  set Balloon(id) [after 500 {Balloon:show %W $Balloon(%W) %X %Y}]
32}
33
34bind Balloon <Button> {
35  set Balloon(first) 0
36  Balloon:kill
37}
38
39bind Balloon <Leave> {
40  set Balloon(first) 0
41  Balloon:kill
42}
43
44bind Balloon <Motion> {
45  if {$Balloon(set) == 0} {
46    after cancel $Balloon(id)
47    set Balloon(id) [after 500 {Balloon:show %W $Balloon(%W) %X %Y}]
48  }
49}
50
51proc Balloon:kill {} {
52  global Balloon
53  after cancel $Balloon(id)
54  if {[winfo exists .balloon] == 1} {
55      destroy .balloon
56  }
57  set Balloon(set) 0
58}
59
60proc Balloon:show {target message {cx 0} {cy 0}} {
61  global Balloon
62  if {$Balloon(first) == 1 } {
63    set Balloon(first) 2
64    if {$cx == 0 && $cy == 0} {
65      set x [expr [winfo rootx $target] + ([winfo width $target]/2)]
66      set y [expr [winfo rooty $target] + [winfo height $target] + 4]
67    } else {
68      set x [expr $cx + 4]
69      set y [expr $cy + 4]
70    }
71    toplevel .balloon -bg black
72    wm overrideredirect .balloon 1
73    label .balloon.l -text $message -relief flat \
74      -bg #ffffcc -fg black -padx 2 -pady 0 -anchor w
75    pack .balloon.l -side left -padx 1 -pady 1
76    wm geometry .balloon +$x+$y
77    set Balloon(set) 1
78  }
79}
80
81proc entry_balloon {target} {
82  global Balloon
83  bind $target <Enter> {
84    incr Balloon(first)
85    set xv [%W xview]
86    if {[string compare [focus] %W] &&
87      [expr [lindex $xv 1] - [lindex $xv 0] < 0.999]} {
88      set Balloon(id) [after 500 {Balloon:entry %W}]
89    }
90  }
91  bind $target <Leave> {
92    catch {after cancel $Balloon(id)}
93    if {![winfo exists .balloon]} {
94      set Balloon(first) 0
95    }
96  }
97  bind $target <Button> {
98    catch {after cancel $Balloon(id)}
99  }
100}
101
102proc Balloon:entry {target} {
103  global Balloon
104  if {$Balloon(first) == 1} {
105    set x [winfo rootx $target]
106    set y [winfo rooty $target]
107    toplevel .balloon -bg black
108    wm overrideredirect .balloon 1
109    label .balloon.l -text [$target get] -relief flat -bg #ffffcc -fg black \
110      -padx 2 -pady 0 -anchor w -font [$target cget -font]
111    pack .balloon.l -side left -padx 1 -pady 1
112    wm withdraw .balloon
113    update idletasks
114    set w [winfo reqwidth .balloon]
115    if {[expr $x + $w > [winfo screenwidth .balloon]]} {
116      set x [expr [winfo screenwidth .balloon] - $w]
117    }
118    wm geometry .balloon +$x+$y
119    update idletasks
120    wm deiconify .balloon
121    bind .balloon <Leave> {
122      set Balloon(first) 0
123      Balloon:kill
124    }
125    bind .balloon <Button> {Balloon:kill}
126  }
127}
128
129