Return to mkCanvText.tcl CVS log

Up to [Micropolis - Activity] / micropolis / src / tk / library / demos

Annotation of micropolis/src/tk/library/demos/mkCanvText.tcl, revision 1.1.1.1

1.1       root        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: }

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.