WJG If anyone's using versions of Tcl earlier than 8.5, then simply replace lassign with:
foreach {x y} [winfo pointerxy $w] {} #----------------------------------------------------------------
# popups.tcl
#----------------------------------------------------------------
# Created by William J Giddings, 2005.
#
# Description:
# -----------
# In automating the conversion of Chinese hanzi into roman pinyin,
# a single character may a have number of variant pronunciations.
# Rather than including all the available choices in the displayed output
# the first item in the list is offered, the text tagged with a unique
# id and the alternatives are then used to create selectable items in a popup-menu.
# Access to the menu occurs when a <Button-3> event occurs over the tagged text.
# Should one of the menu items be selected, the currently displayed
# word is replaced with the new choice.
#
# Usage:
# -----
# See demo proc for example
#----------------------------------------------------------------
namespace eval popup {
set cursor "" ;# store default widget cursor during rollovers
}
#----------------------------------------------------------------
# create menu (m) with from list of supplied items (a)
#----------------------------------------------------------------
proc popup::create {m a} {
# destroy any pre-exising menu with the same name
destroy $m
# create new menus
menu $m -tearoff 0
foreach i $a {
$m add command -label $i -command "popup::swap $m $i"
}
popup::config [winfo parent $m] $m
}
#----------------------------------------------------------------
# display the popup menu adjacent to the current pointer location
#----------------------------------------------------------------
proc popup::show {m} {
set w [winfo parent $m]
lassign [winfo pointerxy $w] x y
set ::active(tag) $m
#get active ta
tk_popup $m $x $y
}
#----------------------------------------------------------------
# swap text displayed in the text widget with the selected menu item
#----------------------------------------------------------------
proc popup::swap {m i} {
# get ranges of tag $m
lassign [[winfo parent $m] tag ranges $m] from to
# swap range content for $i
[winfo parent $m] delete $from $to
[winfo parent $m] insert $from "$i " $m
}
#----------------------------------------------------------------
# configure tag display options and bindings
#----------------------------------------------------------------
proc popup::config {path name} {
$path tag configure $name -foreground red
$path tag bind $name <Button-3> "popup::show $name"
$path tag bind $name <Enter> {
set popup::cursor [%W cget -cursor]
%W configure -cursor arrow
}
$path tag bind $name <Leave> {
%W configure -cursor $popup::cursor
}
}
#----------------------------------------------------------------
# the ubiquitous demo
#----------------------------------------------------------------
proc demo {} {
package require Tk
# build simple GUI
text .txt -font {Palatino 12}
pack .txt -fill both -expand 1
focus .txt
# A few examples
.txt insert insert "A demonstration of alternatives.\nSimply click Button-3 over a red word for a popup menu of choices.\n"
# Step 1) add some tagged words
.txt insert insert "Fruit " .txt.menu_1
# Step 2) build a list of alternatives
set menuitems(1) [list Apple Bannana Cherry Damson Elder]
# Step 3) create popup
popup::create .txt.menu_1 $menuitems(1)
# just a few other entries for company....
.txt insert insert "Trees " .txt.menu_2
set menuitems(2) [list Ash Birch Chestnut ]
popup::create .txt.menu_2 $menuitems(2)
.txt insert insert "Birds " .txt.menu_3
set menuitems(3) [list Blue-Tit Great-Tit Coal-Tit Robin]
popup::create .txt.menu_3 $menuitems(3)
}
demo