Canvas rectangle marking
Summary
Richard Suchenwirth 2002-02-26: I needed to mark an axis-parallel rectangle on a [canvas] by drawing it with the mouse pointer. This is a simplified task compared to Canvas item selections, but the solution could also be done simpler, with a single [bind] proc (which dispatches according to event type), and no global variable required.
Description
In the binding for the <ButtonRelease-1> registration, you specify a "callback": a command name or prefix, to which will be appended a list consisting of the coordinates of the marked rectangle {x0 y0 x1 y1}, and which will then be executed in global scope, as is necessary for bindings:
proc canvas'rect {w x y type {cmd ""}} {
set x [$w canvasx $x]
set y [$w canvasy $y]
switch -- $type {
press {
$w delete rect
$w create rect $x $y $x $y -tag rect
}
motion {
set item [$w find withtag rect]
foreach {x0 y0 x1 y1} [$w coords $item] break
$w coords $item $x0 $y0 $x $y
}
release {
uplevel \#0 [lappend cmd [$w coords [$w find withtag rect]]]
}
default {error "bad type $type: use press, motion, or release"}
}
}
# Usage example and demo:
if {[file tail [info script]] == [file tail $argv0]} {
pack [canvas .c]
bind .c <1> {canvas'rect %W %x %y press}
bind .c <B1-Motion> {canvas'rect %W %x %y motion}
bind .c <ButtonRelease-1> {canvas'rect %W %x %y release "diag %W"}
proc diag {w coords} {
foreach {x0 y0 x1 y1} $coords break
$w create line $x0 $y0 $x1 $y1 -fill green -width 3
$w create line $x1 $y0 $x0 $y1 -fill red -width 3
}
}MGS: Here's a slightly modified version that allows you to draw rectangles in any direction:
proc canvas'rect {w x y type {cmd ""}} {
upvar #0 $w _
set x [$w canvasx $x]
set y [$w canvasy $y]
switch -- $type {
motion {
if { $x < $_(x) } {
set x1 $x ; set x2 $_(x)
} else {
set x1 $_(x) ; set x2 $x
}
if { $y < $_(y) } {
set y1 $y ; set y2 $_(y)
} else {
set y1 $_(y) ; set y2 $y
}
$w coords rect $x1 $y1 $x2 $y2
}
press {
set _(x) $x
set _(y) $y
$w delete rect
$w create rect $x $y $x $y -tag rect
}
release {
unset _(x)
unset _(y)
uplevel #0 [concat $cmd [$w coords rect]]
$w delete rect
}
default {
error "bad type \"$type\": must be motion, press, or release"
}
}
}
# Usage example and demo:
if { [info exists argv0] && [string equal [info script] $argv0] } {
pack [canvas .c]
bind .c <ButtonPress-1> {canvas'rect %W %x %y press}
bind .c <B1-Motion> {canvas'rect %W %x %y motion}
bind .c <ButtonRelease-1> {canvas'rect %W %x %y release "diag %W"}
proc diag {c x1 y1 x2 y2} {
$c create rect $x1 $y1 $x2 $y2
$c create line $x1 $y1 $x2 $y2 -fill green -width 3
$c create line $x2 $y1 $x1 $y2 -fill red -width 3
}
}sheila: 2004-10-27: I was playing around with this on my PC and on my mac. I added a stipple effect to grey out the portion of the image I had added to the canvas. Here is how I changed the code to do this.
release {
# done, remove the saved coords
unset _(x)
unset _(y)
set r [eval $w create rect [$w coords rect]\
-tag exclude -fill gray25 -stipple gray25]
$w delete rect
}aside: I was curious about why you guys used the separate proc instead of just putting it in the release branch, so I put it in the release branch to see how it would work.
Anyway, this works like I thought it would on my PC, but on my mac the stipple looks solid. Everything seems slower on my mac as well. I was wondering what I did wrong? My mac is running panther, and I have the latest TkAquaBI on it (I updated it last night just to be sure).
gold added pix and some categories.
Ref. links Canvas,Canvas lasso selection
