]> git.zerfleddert.de Git - micropolis/blob - src/tk/library/demos/mkCanvText.tcl
df5f09b035bfa348cc72661254da83e9a5bc8d41
[micropolis] / src / tk / library / demos / mkCanvText.tcl
1 # mkCanvText w
2 #
3 # Create a top-level window containing a canvas displaying a text
4 # string and allowing the string to be edited and re-anchored.
5 #
6 # Arguments:
7 # w - Name to use for new top-level window.
8
9 proc mkCanvText {{w .ctext}} {
10 catch {destroy $w}
11 toplevel $w
12 dpos $w
13 wm title $w "Canvas Text Demonstration"
14 wm iconname $w "Text"
15 set c $w.c
16
17 frame $w.frame1 -relief raised -bd 2
18 canvas $c -relief raised -width 500 -height 400
19 button $w.ok -text "OK" -command "destroy $w"
20 pack append $w $w.frame1 {top fill} $w.c {expand fill} \
21 $w.ok {bottom pady 10 frame center}
22 message $w.frame1.m -font -Adobe-Times-Medium-R-Normal-*-180-* -aspect 300 \
23 -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."
24 pack append $w.frame1 $w.frame1.m {frame center}
25
26 set font -Adobe-helvetica-medium-r-*-240-*
27
28 $c create rectangle 245 195 255 205 -outline black -fill red
29
30 # First, create the text item and give it bindings so it can be edited.
31
32 $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]
33 $c bind text <1> "textB1Press $c %x %y"
34 $c bind text <B1-Motion> "textB1Move $c %x %y"
35 $c bind text <Shift-1> "$c select adjust current @%x,%y"
36 $c bind text <Shift-B1-Motion> "textB1Move $c %x %y"
37 $c bind text <KeyPress> "$c insert text cursor %A"
38 $c bind text <Shift-KeyPress> "$c insert text cursor %A"
39 $c bind text <Control-h> "textBs $c"
40 $c bind text <Delete> "textBs $c"
41 $c bind text <Control-d> "$c dchars text sel.first sel.last"
42 $c bind text <Control-v> "$c insert text cursor \[selection get\]"
43
44 # Next, create some items that allow the text's anchor position
45 # to be edited.
46
47 set x 50
48 set y 50
49 set color LightSkyBlue1
50 mkTextConfig $c $x $y -anchor se $color
51 mkTextConfig $c [expr $x+30] [expr $y] -anchor s $color
52 mkTextConfig $c [expr $x+60] [expr $y] -anchor sw $color
53 mkTextConfig $c [expr $x] [expr $y+30] -anchor e $color
54 mkTextConfig $c [expr $x+30] [expr $y+30] -anchor center $color
55 mkTextConfig $c [expr $x+60] [expr $y+30] -anchor w $color
56 mkTextConfig $c [expr $x] [expr $y+60] -anchor ne $color
57 mkTextConfig $c [expr $x+30] [expr $y+60] -anchor n $color
58 mkTextConfig $c [expr $x+60] [expr $y+60] -anchor nw $color
59 set item [$c create rect [expr $x+40] [expr $y+40] [expr $x+50] [expr $y+50] \
60 -outline black -fill red]
61 $c bind $item <1> "$c itemconf text -anchor center"
62 $c create text [expr $x+45] [expr $y-5] -text {Text Position} -anchor s \
63 -font -Adobe-times-medium-r-normal--*-240-* -fill brown
64
65 # Lastly, create some items that allow the text's justification to be
66 # changed.
67
68 set x 350
69 set y 50
70 set color SeaGreen2
71 mkTextConfig $c $x $y -justify left $color
72 mkTextConfig $c [expr $x+30] [expr $y] -justify center $color
73 mkTextConfig $c [expr $x+60] [expr $y] -justify right $color
74 $c create text [expr $x+45] [expr $y-5] -text {Justification} -anchor s \
75 -font -Adobe-times-medium-r-normal--*-240-* -fill brown
76
77 $c bind config <Enter> "textEnter $c"
78 $c bind config <Leave> "$c itemconf current -fill \$textConfigFill"
79 }
80
81 proc mkTextConfig {w x y option value color} {
82 set item [$w create rect [expr $x] [expr $y] [expr $x+30] [expr $y+30] \
83 -outline black -fill $color -width 1]
84 $w bind $item <1> "$w itemconf text $option $value"
85 $w addtag config withtag $item
86 }
87
88 set textConfigFill {}
89
90 proc textEnter {w} {
91 global textConfigFill
92 set textConfigFill [lindex [$w itemconfig current -fill] 4]
93 $w itemconfig current -fill black
94 }
95
96 proc textB1Press {w x y} {
97 $w cursor current @$x,$y
98 $w focus current
99 focus $w
100 $w select from current @$x,$y
101 }
102
103 proc textB1Move {w x y} {
104 $w select to current @$x,$y
105 }
106
107 proc textBs {w} {
108 set char [expr {[$w index text cursor] - 1}]
109 if {$char >= 0} {$w dchar text $char}
110 }
Impressum, Datenschutz