lib/gui_script/balloon.tcl

   1
   2 array set Balloon {
   3   set 0
   4   first 0
   5   id ""
   6 }
   7
   8 proc 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
  24 proc end_balloon {target} {
  25   set_balloon $target ""
  26 }
  27
  28 bind 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
  34 bind Balloon <Button> {
  35   set Balloon(first) 0
  36   Balloon:kill
  37 }
  38
  39 bind Balloon <Leave> {
  40   set Balloon(first) 0
  41   Balloon:kill
  42 }
  43
  44 bind 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
  51 proc 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
  60 proc 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
  81 proc 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
 102 proc 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