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