111 lines
4.4 KiB
Tcl
111 lines
4.4 KiB
Tcl
# mkCanvText w
|
|
#
|
|
# Create a top-level window containing a canvas displaying a text
|
|
# string and allowing the string to be edited and re-anchored.
|
|
#
|
|
# Arguments:
|
|
# w - Name to use for new top-level window.
|
|
|
|
proc mkCanvText {{w .ctext}} {
|
|
catch {destroy $w}
|
|
toplevel $w
|
|
dpos $w
|
|
wm title $w "Canvas Text Demonstration"
|
|
wm iconname $w "Text"
|
|
set c $w.c
|
|
|
|
message $w.msg -font -Adobe-Times-Medium-R-Normal-*-180-* -width 420 \
|
|
-relief raised -bd 2 -text "This window displays a string of text to demonstrate the text facilities of canvas widgets. You can point, click, and type. You can also select and then delete with Control-d. You can copy the selection with Control-v. You can click in the boxes to adjust the position of the text relative to its positioning point or change its justification."
|
|
canvas $c -relief raised -width 500 -height 400
|
|
button $w.ok -text "OK" -command "destroy $w"
|
|
pack $w.msg -side top -fill both
|
|
pack $w.c -side top -expand yes -fill both
|
|
pack $w.ok -side bottom -pady 5 -anchor center
|
|
|
|
set font -Adobe-helvetica-medium-r-*-240-*
|
|
|
|
$c create rectangle 245 195 255 205 -outline black -fill red
|
|
|
|
# First, create the text item and give it bindings so it can be edited.
|
|
|
|
$c addtag text withtag [$c create text 250 200 -text "This is just a string of text to demonstrate the text facilities of canvas widgets. You can point, click, and type. You can also select and then delete with Control-d." -width 440 -anchor n -font $font -justify left]
|
|
$c bind text <1> "textB1Press $c %x %y"
|
|
$c bind text <B1-Motion> "textB1Move $c %x %y"
|
|
$c bind text <Shift-1> "$c select adjust current @%x,%y"
|
|
$c bind text <Shift-B1-Motion> "textB1Move $c %x %y"
|
|
$c bind text <KeyPress> "$c insert text insert %A"
|
|
$c bind text <Shift-KeyPress> "$c insert text insert %A"
|
|
$c bind text <Return> "$c insert text insert \\n"
|
|
$c bind text <Control-h> "textBs $c"
|
|
$c bind text <Delete> "textBs $c"
|
|
$c bind text <Control-d> "$c dchars text sel.first sel.last"
|
|
$c bind text <Control-v> "$c insert text insert \[selection get\]"
|
|
|
|
# Next, create some items that allow the text's anchor position
|
|
# to be edited.
|
|
|
|
set x 50
|
|
set y 50
|
|
set color LightSkyBlue1
|
|
mkTextConfig $c $x $y -anchor se $color
|
|
mkTextConfig $c [expr $x+30] [expr $y] -anchor s $color
|
|
mkTextConfig $c [expr $x+60] [expr $y] -anchor sw $color
|
|
mkTextConfig $c [expr $x] [expr $y+30] -anchor e $color
|
|
mkTextConfig $c [expr $x+30] [expr $y+30] -anchor center $color
|
|
mkTextConfig $c [expr $x+60] [expr $y+30] -anchor w $color
|
|
mkTextConfig $c [expr $x] [expr $y+60] -anchor ne $color
|
|
mkTextConfig $c [expr $x+30] [expr $y+60] -anchor n $color
|
|
mkTextConfig $c [expr $x+60] [expr $y+60] -anchor nw $color
|
|
set item [$c create rect [expr $x+40] [expr $y+40] [expr $x+50] [expr $y+50] \
|
|
-outline black -fill red]
|
|
$c bind $item <1> "$c itemconf text -anchor center"
|
|
$c create text [expr $x+45] [expr $y-5] -text {Text Position} -anchor s \
|
|
-font -Adobe-times-medium-r-normal--*-240-* -fill brown
|
|
|
|
# Lastly, create some items that allow the text's justification to be
|
|
# changed.
|
|
|
|
set x 350
|
|
set y 50
|
|
set color SeaGreen2
|
|
mkTextConfig $c $x $y -justify left $color
|
|
mkTextConfig $c [expr $x+30] [expr $y] -justify center $color
|
|
mkTextConfig $c [expr $x+60] [expr $y] -justify right $color
|
|
$c create text [expr $x+45] [expr $y-5] -text {Justification} -anchor s \
|
|
-font -Adobe-times-medium-r-normal--*-240-* -fill brown
|
|
|
|
$c bind config <Enter> "textEnter $c"
|
|
$c bind config <Leave> "$c itemconf current -fill \$textConfigFill"
|
|
}
|
|
|
|
proc mkTextConfig {w x y option value color} {
|
|
set item [$w create rect [expr $x] [expr $y] [expr $x+30] [expr $y+30] \
|
|
-outline black -fill $color -width 1]
|
|
$w bind $item <1> "$w itemconf text $option $value"
|
|
$w addtag config withtag $item
|
|
}
|
|
|
|
set textConfigFill {}
|
|
|
|
proc textEnter {w} {
|
|
global textConfigFill
|
|
set textConfigFill [lindex [$w itemconfig current -fill] 4]
|
|
$w itemconfig current -fill black
|
|
}
|
|
|
|
proc textB1Press {w x y} {
|
|
$w icursor current @$x,$y
|
|
$w focus current
|
|
focus $w
|
|
$w select from current @$x,$y
|
|
}
|
|
|
|
proc textB1Move {w x y} {
|
|
$w select to current @$x,$y
|
|
}
|
|
|
|
proc textBs {w} {
|
|
set char [expr {[$w index text insert] - 1}]
|
|
if {$char >= 0} {$w dchar text $char}
|
|
}
|