use strict;
use Tcl::Tk;
my $mw = Tcl::Tk::tkinit;
$mw->interp->Eval(<<'EOS');
package require tkdnd
## Iconify ".". We are going to add windows and call update many times
+.
## Avoid some interesting visual effects :-)
wm withdraw .
#---------------------------------------------------------------------
+---------
# Step 1: A simple Drag Source
#---------------------------------------------------------------------
+---------
# create the source window
label .source -text "source" -relief groove -bd 2 -width 20
pack .source -pady 5
# tells the DND protocol source can deliver textual data
dnd bindsource .source text/plain {return "testing DND"}
# bind the DND operation on left button
bind .source <1> {dnd drag %W}
#---------------------------------------------------------------------
+---------
# Step 1: A simple Drop Target accepting plain text
#---------------------------------------------------------------------
+---------
# defines the target window
label .text_plain -text "drop plain text" -relief raised -bd 1 -width
+20
pack .text_plain -pady 5
# Before registering a drop target, we always have to make sure the
# corresponding widget has been created:
update idle
# tells the DND protocol target can handle textual data
dnd bindtarget .text_plain text/plain <Drop> \
{%W configure -text %D; status "\[target1\] type='%T', action='%A'"
after 2000 {%W configure -text "drop plain text"}}
#---------------------------------------------------------------------
+---------
# Step 2: Management of multiple types on the source
#---------------------------------------------------------------------
+---------
# defines an other type on source
dnd bindsource .source TK_COLOR {return "pink"}
# defines a target window
label .target2 -text "drop color" -relief raised -bd 1 -width 20 \
-bg lightyellow
pack .target2 -pady 5
# tells the DND protocol target can handle color data
dnd bindtarget .target2 TK_COLOR <Drop> {
status "\[target2\] type='%T', data='%D', action='%A'"
.target2 configure -bg %D
after 2000 ".target2 configure -bg lightyellow"
}
#=====================================================================
+=========
# END
#=====================================================================
+=========
proc status {msg} {
.status configure -text $msg
}
proc init {} {
wm title . "Simple Drag & Drop Demo..."
label .status -relief sunken -bd 1 -width 60 -anchor w
pack .status -side bottom -fill x
pack [frame .sep -height 10] -side bottom -fill x
pack propagate .status 0
}
init
update
wm deiconify .
EOS
# Tcl inclusion for GUI finished here; you can work with widgets here
+like:
# my $lab = $mw->interp->widget('.status');
# $lab->configure(-text=>'new text here...');
Tcl::Tk::MainLoop;
2nd method is reworked a bit to be more Perl-looking:
use strict;
use Tcl::Tk;
my $mw = Tcl::Tk::tkinit;
my $interp = $mw->interp;
$interp->invoke('package', 'require', 'tkdnd');
## Iconify ".". We are going to add windows and call update many times
+.
## Avoid some interesting visual effects :-)
#wm withdraw .
#---------------------------------------------------------------------
+---------
# Step 1: A simple Drag Source
#---------------------------------------------------------------------
+---------
# create the source window
my $lab_source = $mw->Label(-text=>"source", qw/-relief groove -bd 2 -
+width 20/)->pack(-pady=>5);
# tells the DND protocol source can deliver textual data
$interp->call('dnd','bindsource', $lab_source->path, 'text/plain', q{r
+eturn "testing DND"});
# bind the DND operation on left button
$interp->call('bind', $lab_source->path, '<1>', 'dnd drag %W');
#---------------------------------------------------------------------
+---------
# Step 1: A simple Drop Target accepting plain text
#---------------------------------------------------------------------
+---------
# defines the target window
my $lab_text_plain = $mw->Label(-text=>"drop plain text", qw/-relief r
+aised -bd 1 -width 20/)->pack(-pady=>5);
# Before registering a drop target, we always have to make sure the
# corresponding widget has been created:
$interp->update('idle');
# tells the DND protocol target can handle textual data
$interp->call('dnd','bindtarget', $lab_text_plain, 'text/plain', '<Dro
+p>', \\'WDTA', sub {
my (undef,$int,$sub) = (shift,shift,shift);
my ($W,$D,$T,$A) = (@_); # Ev vars
my $receiver_widget = $int->widget($W);
$receiver_widget->configure(-text=>$D);
status("[target1] type='$T', action='$A'");
$int->after(2000, sub {$receiver_widget->configure(-text=>"drop pl
+ain text")});
});
#---------------------------------------------------------------------
+---------
# Step 2: Management of multiple types on the source
#---------------------------------------------------------------------
+---------
# defines an other type on source
$interp->call('dnd','bindsource', $lab_source->path, 'TK_COLOR', q{ret
+urn "pink"});
# defines a target window
my $lab_t2 = $mw->Label(-text=>"drop color", qw/-relief raised -bd 1 -
+width 20 -bg lightyellow/)
->pack(-pady=>5);
# tells the DND protocol target can handle color data
$interp->call('dnd','bindtarget', $lab_t2, 'TK_COLOR', '<Drop>', , \\
+'WDTA', sub {
my (undef,$int,$sub) = (shift,shift,shift);
my ($W,$D,$T,$A) = (@_); # Ev vars
$lab_t2->configure(-bg=>$D);
status("[target1] type='$T', action='$A'");
$int->after(2000, sub {$lab_t2->configure(-bg=>'lightyellow')});
});
#=====================================================================
+=========
# END
#=====================================================================
+=========
$interp->wm('title','.',"Simple Drag & Drop Demo...");
my $lab_stat = $mw->Label(qw/-relief sunken -bd 1 -width 60 -anchor w/
+)->pack(qw/-side bottom -fill x/);
$mw->Frame(-height=>10)->pack(qw/-side bottom -fill x/);
sub status {
my $msg = shift;
$lab_stat->configure(-text=>$msg);
}
$mw->update;
$interp->MainLoop;
Best regards,
Courage, the Cowardly Dog
|