Richard Suchenwirth 2006-04-19 - A question on comp.lang.tcl prompted me to experiment how one could interactively resize a rectangle on a canvas. Just click close enough to the center of a side, then you can "move" that side with mouse button 1 held down. Should you click elsewhere, you can move the whole rectangle around.
proc resize'rect'click {w x y} {
global X Y RSZPOS ID
set X [$w canvasx $x]
set Y [$w canvasy $y]
catch {unset RSZPOS}
set ID [$w find withtag current]
set coords [$w coords $ID]
foreach {x0 y0 x1 y1} $coords break
if {[between $x0 $y0 $X $Y $x0 $y1]} {
set RSZPOS 0
} elseif {[between $x0 $y1 $X $Y $x1 $y1]} {
set RSZPOS 3
} elseif {[between $x1 $y1 $X $Y $x1 $y0]} {
set RSZPOS 2
} elseif {[between $x1 $y0 $X $Y $x0 $y0]} {
set RSZPOS 1
}
}
proc resize'rect {w x y} {
global X Y RSZPOS ID
set x [$w canvasx $x]
set y [$w canvasy $y]
if [info exists RSZPOS] {
set coords [$w coords $ID]
set d [expr {$RSZPOS%2? $y: $x}]
$w coords $ID [lset coords $RSZPOS $d]
} else {
$w move $ID [expr {$x-$X}] [expr {$y-$Y}]
}
set X $x; set Y $y
}
proc between {x0 y0 x1 y1 x2 y2} {
set t 10
set xm [expr {($x0+$x2)/2.}]
set ym [expr {($y0+$y2)/2.}]
expr {abs($xm-$x1)<$t && abs($ym-$y1)<$t}
}#-- Testing, demo, usage example:
package require Tk
pack [canvas .c]
.c create rect 50 50 100 100 -fill red -tag rsz
.c create rect 150 50 200 100 -fill blue -tag rsz
.c bind rsz <1> {resize'rect'click %W %x %y}
.c bind rsz <B1-Motion> {resize'rect %W %x %y}