Updated 2013-03-05 12:16:44 by pooryorick

Summary  edit

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  edit

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