Posted to tcl by ro at Wed Jan 02 09:17:25 GMT 2008view raw

  1. load [file join $dir megaimage.dll]
  2. load [file join $dir megaimagetk.dll]
  3.  
  4. set size 100
  5. set obj_x 100
  6. set obj_y 50
  7.  
  8. set canvas_width 600
  9. set canvas_height 800
  10.  
  11. set obj [megaimage-blank $canvas_width $canvas_height]
  12. $obj rectangle $obj_x $obj_y $size $size {255 255 255 0}
  13.  
  14. pack [megaimage.frame .f] -fill both -expand 1
  15. .f size $canvas_width $canvas_height
  16. .f objsetimage $obj
  17.  
  18.  
  19. proc move_start {X Y} {
  20. global qx qy
  21. set qx $X ; set qy $Y
  22. }
  23.  
  24. proc move_motion {X Y} {
  25. global qx qy
  26. set dx [expr {$X - $qx}]
  27. set dy [expr {$Y - $qy}]
  28. set qx $X ; set qy $Y
  29.  
  30. global obj
  31. global size
  32. global obj_x obj_y
  33. global canvas_width canvas_height
  34.  
  35. # blank the canvas to black
  36. $obj rectangle 0 0 $canvas_width $canvas_height {0 0 0 0}
  37.  
  38. set obj_x [expr {$obj_x + $dx}]
  39. set obj_y [expr {$obj_y + $dy}]
  40. $obj rectangle $obj_x $obj_y $size $size {255 255 255 0}
  41.  
  42. .f objsetimage $obj
  43.  
  44. }
  45.  
  46.  
  47. bind .f <1> [list move_start %X %Y]
  48. bind .f <Button1-Motion> [list move_motion %X %Y]
  49.