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     ! 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.