Posted to tcl by kevin_walzer at Sat Jan 31 15:56:54 GMT 2009view raw

  1. namespace eval simplednd {
  2.  
  3.  
  4. #create the drag icon with empty text and image to initialize; then hide the icon
  5. proc makeDragIcon {txt img} {
  6.  
  7. variable dragicon
  8. variable dragtext
  9. variable dragimage
  10.  
  11. #create the icon
  12. set dragicon [toplevel .dnd]
  13. set dragtext $txt
  14. set dragimage $img
  15.  
  16. wm overrideredirect $dragicon true
  17.  
  18.  
  19. label $dragicon.view -image $dragimage -text $dragtext -compound left
  20. pack $dragicon.view
  21.  
  22. #now hide the icon
  23. wm withdraw $dragicon
  24.  
  25. }
  26.  
  27. #register widget to respond to drag events: widget to register, its target widget, callback to associate with this drag event, text for the drag label, and image for the drag label
  28. proc dragRegister {w target dragcmd dropcmd} {
  29.  
  30. variable dragicon
  31. variable dragtext
  32. variable dragimage
  33.  
  34. catch {simplednd::makeDragIcon {} {}}
  35.  
  36. puts "$w registered as dragsite with $target as the drop target"
  37.  
  38. #binding for when drag motion begins
  39. bind $w <B1-Motion> [list [namespace current]::dragMove %W %X %Y $dragcmd $target]
  40.  
  41. #binding for when drop event occurs
  42. bind $w <ButtonRelease-1> [list [namespace current]::dragStop %W %X %Y $target $dropcmd ]
  43.  
  44. }
  45.  
  46. #drag motion with following args: source widget, cursor x position, cursor y position, drag command, target widget
  47. proc dragMove {w x y dragcmd target} {
  48.  
  49. variable dragicon
  50. variable dragtext
  51. variable dragimage
  52.  
  53. #the dragcmd properly configures the drag icon
  54. eval $dragcmd
  55.  
  56. #configure drag icon with customized text and image
  57. $dragicon.view configure -text $dragtext -image $dragimage
  58.  
  59. #dragicon appears
  60. wm deiconify $dragicon
  61.  
  62. #change cursor to drag cursor
  63. $w configure -cursor diamond_cross
  64.  
  65. catch {raise $dragicon}
  66.  
  67. #this places the drag icon right above the cursor
  68. set x [expr {$x - ([winfo reqwidth $dragicon] / 2) }]
  69. set y [expr {$y - [winfo reqheight $dragicon] - 6 }]
  70.  
  71. wm geometry $dragicon +$x+$y
  72.  
  73. update
  74. }
  75.  
  76. #dragstop/drop event with following args: source widget, cursor x position, cursor y position, target widget, dropcommand: if over drop target, execute dropcommand; otherwise simply return
  77. proc dragStop {w x y target dropcmd} {
  78.  
  79. variable dragicon
  80. variable dragtext
  81. variable dragimage
  82.  
  83. #hide dragicon on drop event
  84. wm withdraw $dragicon
  85.  
  86. #change cursor back to arrow
  87. $w configure -cursor arrow
  88.  
  89. #execute callback or simply return
  90. if {[winfo containing $x $y] != $target} {
  91. puts "target $w not reached"
  92. } else {
  93. focus -force $target
  94. eval $dropcmd
  95. }
  96. }
  97.  
  98.  
  99. #demo package
  100. proc demo {} {
  101.  
  102. variable dragicon
  103. variable dragtext
  104. variable dragimage
  105.  
  106.  
  107. #create image for demo
  108. image create photo dnd_demo -data {R0lGODlhEAAQALMAAAAAAMbGxv//////////////////////////////////\
  109. /////////////////////yH5BAEAAAEALAAAAAAQABAAAAQwMMhJ6wQ4YyuB\
  110. +OBmeeDnAWNpZhWpmu0bxrKAUu57X7VNy7tOLxjIqYiapIjDbDYjADs=}
  111.  
  112. listbox .l -selectmode single -activestyle none
  113. listbox .b -selectmode single -activestyle none
  114.  
  115. foreach item {do re mi} {
  116. .l insert end $item
  117. }
  118.  
  119. foreach item {fa so la} {
  120. .b insert end $item
  121. }
  122.  
  123. pack .l -side left
  124. pack .b -side right
  125.  
  126.  
  127. #register drag sources, drag targets, and callbacks
  128. dragRegister .l .b [namespace current]::drag_l [namespace current]::drop_l
  129.  
  130. dragRegister .b .l [namespace current]::drag_b [namespace current]::drop_b
  131.  
  132. }
  133.  
  134. #dragcommand for demo l widget: configures dragicon
  135. proc drag_l {} {
  136.  
  137. variable dragicon
  138. variable dragtext
  139. variable dragimage
  140.  
  141. set item [lindex [.l get [.l curselection]]]
  142. set dragtext $item
  143. set dragimage dnd_demo
  144.  
  145. }
  146.  
  147.  
  148. #dropcommand for demo l widget: callback to execute on drop
  149. proc drop_l {} {
  150.  
  151. variable dragicon
  152. variable dragtext
  153. variable dragimage
  154.  
  155. .b insert end $dragtext
  156.  
  157. .l delete [.l curselection]
  158. }
  159.  
  160. #dragcommand for demo b widget: configures dragicon
  161. proc drag_b {} {
  162.  
  163. variable dragicon
  164. variable dragtext
  165. variable dragimage
  166.  
  167. set item [lindex [.b get [.b curselection]]]
  168. set dragtext $item
  169. set dragimage dnd_demo
  170.  
  171. }
  172.  
  173.  
  174. #dropcommand for demo b widget: callback to execute on drop
  175. proc drop_b {} {
  176.  
  177. variable dragicon
  178. variable dragtext
  179. variable dragimage
  180.  
  181. .l insert end $dragtext
  182.  
  183. .b delete [.b curselection]
  184. }
  185.  
  186.  
  187.  
  188. namespace export *
  189.  
  190. }
  191.  
  192. ::simplednd::demo