applet.tcl

   1
   2 #----- general machinery -----
   3
   4 package require tktray
   5
   6 wm withdraw .
   7
   8 tktray::icon .i -class example
   9 .i configure -docked 1
  10
  11 set posted 0
  12
  13 foreach b {1 3} {
  14     menu .m$b -tearoff 0
  15 }
  16
  17 proc pressed {b x y} {
  18     global posted
  19     tooltip_cancel
  20     if {$posted == $b} {
  21         puts "unpost $posted toggle"
  22         .m$posted unpost
  23         set posted 0
  24     } elseif {[winfo exists .m$b]} {
  25         if {$posted} {
  26             .m$posted unpost
  27             puts "unpost $posted other"
  28         }
  29         puts "post $b"
  30         set posted $b
  31         .m$b post $x $y
  32     }
  33 }
  34
  35 proc msel {} {
  36     global posted
  37     set posted 0
  38 }
  39
  40 bind .i <ButtonPress> { pressed %b %X %Y }
  41
  42 proc tooltip_starttimer {state x y} {
  43     global tooltip_after posted tooltip_inwindow
  44     if {$state || $posted || !$tooltip_inwindow} { tooltip_cancel; return }
  45     catch { after cancel $tooltip_after }
  46     set tooltip_after [after 500 tooltip_show $x $y]
  47 }
  48
  49 proc tooltip_cancel {} {
  50     global tooltip_after
  51     catch { after cancel $tooltip_after }
  52     catch { unset $tooltip_after }
  53     wm withdraw .tt
  54 }
  55
  56 set tooltip_inwindow 0
  57
  58 proc tooltip_enter {state x y} {
  59     global tooltip_inwindow
  60     set tooltip_inwindow 1
  61     tooltip_starttimer $state $x $y
  62 }
  63
  64 proc tooltip_leave {} {
  65     global tooltip_inwindow
  66     set tooltip_inwindow 0
  67     tooltip_cancel
  68 }
  69
  70 proc setuptooltip {} {
  71     bind .i <Enter> { tooltip_enter %s %X %Y }
  72     bind .i <Leave> { tooltip_leave }
  73     bind .i <ButtonRelease> { tooltip_cancel; tooltip_starttimer %s %X %Y }
  74     bind .i <Motion> { tooltip_starttimer %s %X %Y }
  75     toplevel .tt -background black
  76     wm withdraw .tt
  77     wm overrideredirect .tt 1
  78     label .tt.t -justify left -background {#EEE1B3}
  79     pack .tt.t -padx 1 -pady 1
  80     settooltip {}
  81 }
  82
  83 proc settooltip {s} {
  84     .tt.t configure -text $s
  85 }
  86
  87 proc tooltip_show {x y} {
  88     incr x 9
  89     incr y 9
  90     wm geometry .tt +$x+$y
  91     wm deiconify .tt
  92 }
  93
  94 proc setimage {image} {
  95     .i configure -image $image
  96 }