package require Tk #------- # movement handler #------- proc drag.canvas.item {canWin item newX newY} { set xDiff [expr {$newX - $::x}] set yDiff [expr {$newY - $::y}] #test before moving if {[inside $canWin $item $xDiff $yDiff]} { puts inside $canWin move $item $xDiff $yDiff } set ::x $newX set ::y $newY } #------- # test to see if the new position is outside the canvas viewport #------- proc inside {w item xDiff yDiff} { #canvas extents set can(minx) -1 set can(miny) -1 set can(maxx) [winfo width $w ] set can(maxy) [winfo height $w ] #item coords set item [$w coords $item] #check min values foreach {x y} $item { set x [expr $x + $xDiff] set y [expr $y + $yDiff] if {$x < $can(minx)} { return 0 } if {$y < $can(miny)} { return 0 } if {$x > $can(maxx)} { return 0 } if {$y > $can(maxy)} { return 0 } } #puts $item return 1 } #------- # test it #------- pack [canvas .c -bg white] -expand 1 -fill both button .b -text "Test Button" .c create rectangle 0 0 100 100 -fill red -tag tag .c bind tag <1> { set ::x %X set ::y %Y } .c bind tag <B1-Motion> [list drag.canvas.item .c tag %X %Y]
Category GUI Category Widget