git.zerfleddert.de Git - micropolis/blob - 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 }