Package DragNDrop

 

ulis, 2006-09-01. Un petit paquet pour ajouter un drag'n'drop à Tk.


Pourquoi

Parce que ça manque dans Tk.


Comment

Un binding sur la source pour déplacer une image ou un texte vers la destination. Un binding sur la destination pour recevoir l'évènement <<DragNDrop>>.


Installation


Utilisation

  package require DragNDrop
  canvas .c ...
  button .b ...
  label  .l ...
  sender .b .c .l
  bind .r1 <<DragNDrop>> \
  { .r1 config -text [receive .r1 -text] }
  bind .r2 <<DragNDrop>> \
  { .r2 config -image [receive .r2 -image] }
  sender <path>...
  # getting a list of -option value
  receive <path>
  # getting a value
  receive <path> -<option>
  -sender     sender path
  -image      image sent or ""
  -text       text sent or ""
  -tags       sender item tags
  -x          drop x
  -y          drop y

Package DragNDrop.tcl

  if {[info exists ::dragndrop::version]} { return }

  namespace eval ::dragndrop \
  {
  # #####################################
  #
  # package de drag'n'drop
  #
  variable version 1.0
  #
  # (c) ulis, 2006
  # licence NOL
  # -------------------------------------
  # Usage:
  #   canvas .c ...
  #   button .b ...
  #   label  .l ...
  #   sender .b .c .l
  #   bind .r1 <<DragNDrop>> \
  #   { .r1 config -text [receive .r1 -text] }
  #   bind .r2 <<DragNDrop>> \
  #   { .r2 config -image [receive .r2 -image] }
  # #####################################

    # ==========================
    #
    # package
    #
    # ==========================

    package require Tk
    package provide DragNDrop $version

    # ====================
    #
    # entry points
    #
    # ====================

    namespace export sender receive

    # ====================
    #
    #   global variables
    #
    # ====================

    variable {}
    array set {} {}

    # ====================
    #
    #   Bindings
    #
    # ====================

    bind Dragndrop   <ButtonPress-1>   { ::dragndrop::press   %W %x %y }
    bind Dragndrop   <ButtonRelease-1> { ::dragndrop::release %W %X %Y }
    bind Dragndrop   <Motion>          { ::dragndrop::motion  %W %X %Y }

    # ====================
    #
    #   sender proc
    #
    # ====================

    proc sender {args} \
    {
      variable {}
      set rc [catch \
      {
        if {[llength $args] == 0} { error "usage: sender path..." }
        foreach w $args \
        { bindtags $w [linsert [bindtags $w] end-2 Dragndrop] }
      } msg]
      return -code $rc $msg
    }

    # ====================
    #
    #   receive proc
    #
    # ====================

    proc receive {args} \
    {
      variable {}
      set rc [catch \
      {
        switch [llength $args] \
        {
          1       \
          {
            foreach {w} $args break
            if {![info exists ($w:snd)]} \
            { error "unknown dragndrop receiver '$w'" }
            set res [list]
            lappend res -image  $($w:img)
            lappend res -sender $($w:snd)
            lappend res -tags   $($w:tag)
            lappend res -text   $($w:txt)
            lappend res -x      $($w:x)
            lappend res -y      $($w:y)
            set res
          }
          2       \
          {
            foreach {w option} $args break
            if {![info exists ($w:snd)]} \
            { error "unknown dragndrop receiver '$w'" }
            switch -glob -- $option \
            {
              -img    -
              -ima*   { set ($w:img) }
              -snd    -
              -sen*   { set ($w:snd) }
              -tag*   { set ($w:tag) }
              -txt    -
              -tex*   { set ($w:txt) }
              -x      { set ($w:x) }
              -y      { set ($w:y) }
              default \
              { error "unknown option '$option'" }
            }
          }
          default { error "usage: dragndrop path -option" }
        }
      } msg]
      return -code $rc $msg
    }

    # ====================
    #
    #   Binding procs
    #
    # ====================

    # press - ButtonPress-1 binding

    proc press {w x y} \
    {
      variable {}
      if {[$w cget -state] == "disabled"} { return }
      set img ""
      set class [winfo class $w]
      switch -- $class \
      {
        Canvas      \
        {
          foreach id [$w fin overlapping $x $y $x $y] \
          {
            set x0 ""
            set type [$w type $id]
            if {$type == "image"} \
            {
              foreach {x0 y0 x1 y1} [$w bbox $id] break
              set img [$w itemcget $id -image]
              set tags [$w itemcget $id -tags]
              set text [lindex $tags 0]
              break
            } \
            elseif {$type == "text"} \
            {
              foreach {x0 y0 x1 y1} [$w bbox $id] break
              set text [$w itemcget $id -text]
              set img ""
              set tags [$w itemcget $id -tags]
              break
            }
          }
        }
        Button      -
        Label       \
        {
          set img [$w cget -image]
          set text [$w cget -text]
          set tags $w
          set x0 [$w cget -padx]
          set y0 [$w cget -pady]
        }
      }
      if {$x0 == ""} { return }
      set (dx) [expr {$x - $x0}]
      set (dyJL