home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Win32Site.pm < prev    next >
Encoding:
Perl POD Document  |  2004-01-10  |  963 b   |  52 lines
  1. package Tk::DragDrop::Win32Site;
  2.  
  3. use vars qw($VERSION);
  4. $VERSION = sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/;
  5.  
  6. use Tk qw($XS_VERSION);
  7. require DynaLoader;
  8. require Tk::DropSite;
  9.  
  10. use base qw(Tk::DropSite DynaLoader);
  11.  
  12. bootstrap Tk::DragDrop::Win32Site;
  13.  
  14. use strict;
  15.  
  16. Tk::DropSite->Type('Win32');
  17.  
  18. sub WM_DROPFILES () {563}
  19.  
  20. sub InitSite
  21. {
  22.  my ($class,$site) = @_;
  23.  my $w = $site->widget;
  24.  $w->BindClientMessage(WM_DROPFILES,[\&Win32Drop,$site]);
  25.  DragAcceptFiles($w,1);
  26.  warn "Enable $w";
  27. }
  28.  
  29. sub Win32Drop
  30. {
  31.  # print join(',',@_),"\n";
  32.  my ($w,$site,$msg,$wParam,$lParam) = @_;
  33.  my ($x,$y,@files) = DropInfo($wParam);
  34.  my $cb = $site->{'-dropcommand'};
  35.  $site->Apply(-entercommand => $x, $y, 0);
  36.  if ($cb)
  37.   {
  38.    foreach my $file (@files)
  39.     {
  40.      # print "$file @ $x,$y\n";
  41.      $w->clipboardClear;
  42.      $w->clipboardAppend('--',$file);
  43.      $cb->Call('CLIPBOARD',$x,$y);
  44.     }
  45.   }
  46.  $site->Apply(-entercommand => $x, $y, 1);
  47.  return 0;
  48. }
  49.  
  50. 1;
  51. __END__
  52.