Posted to tcl by ro at Wed Jan 02 09:00:03 GMT 2008view raw

  1.  
  2. load [file join $dir megaimage.dll]
  3. load [file join $dir megaimagetk.dll]
  4.  
  5. set size 100
  6. set obj_x 100
  7. set obj_y 50
  8.  
  9. set canvas_width 600
  10. set canvas_height 800
  11.  
  12.  
  13. set p [image create photo]
  14. pack [label .p -width $canvas_width -height $canvas_height] \
  15. -fill both -expand 1
  16. .p conf -image $p
  17.  
  18.  
  19. set obj [megaimage-blank $canvas_width $canvas_height]
  20. $obj rectangle 0 0 $canvas_width $canvas_height {0 0 0 255}
  21. $obj rectangle $obj_x $obj_y $size $size {255 255 255 255}
  22. megaimage.put.on.photo [$obj getdata] $p 0 0 set
  23.  
  24.  
  25. proc move_start {X Y} {
  26. global qx qy
  27. set qx $X ; set qy $Y
  28. }
  29.  
  30. proc move_motion {X Y} {
  31. global qx qy
  32. set dx [expr {$X - $qx}]
  33. set dy [expr {$Y - $qy}]
  34. set qx $X ; set qy $Y
  35.  
  36. global obj
  37. global size
  38. global obj_x obj_y
  39. global canvas_width canvas_height
  40. global p
  41.  
  42.  
  43. set obj_x [expr {$obj_x + $dx}]
  44. set obj_y [expr {$obj_y + $dy}]
  45.  
  46. $obj rectangle 0 0 $canvas_width $canvas_height {0 0 0 255}
  47. $obj rectangle $obj_x $obj_y $size $size {255 255 255 255}
  48. megaimage.put.on.photo [$obj getdata] $p 0 0 set
  49.  
  50.  
  51. }
  52.  
  53.  
  54. bind .p <1> [list move_start %X %Y]
  55. bind .p <Button1-Motion> [list move_motion %X %Y]
  56.