in reply to Re^2: Tcl & Tcl::Tk used for 1 main window
in thread Tcl & Tcl::Tk used for 1 main window

"or an example of a working Tkx listbox"

# a routine using perl and tkx to make it easy to collect lists of dir
+s and files
# for xp-sp3 (win32::clipboard) 
# it allows you to drag files and dirs out of windows explorer type th
+ings
# and drop them into a listbox where their names get recorded
# A small area called topdir can aso recieve dropped things seperatly 


# see http://code.activestate.com/lists/perl-tcltk/357/
#     http://code.activestate.com/lists/perl-tcltk/356/
#     http://www.perlmonks.org/index.pl/jacques?parent=824717;node_id=
+3333
#     http://coding.derkeiler.com/Archive/Tcl/comp.lang.tcl/2006-04/ms
+g00026.html
#     http://www.ellogon.org/petasis/tcltk-projects/tkdnd/tkdnd-man-pa
+ge

use strict;
use Win32::Clipboard;

use Tkx;

  if (-d 'd:/active') { $main::myactive='D:/active'; } 
  elsif (-d 'C:/active') { $main::myactive='C:/active'; } 
#  print "myactive=".$main::myactive."\n"; 


######################################################################
+#############
# because tkdnd is not in the activestate tkkit 
#   and i didnt want to install tcl/tk and tkdnd we need to do the fol
+lowing 
######################################################################
+#############
#Get tkdnd from http://sourceforge.net/projects/tkdnd/files/ 
#   (I used the Windows binary)
# unzip it and put  it somewhere and lappend that dir below 
######################################################################
+#############
# notes from guy whos questions helped so much in figureing this out 
#Note 1 on where to put tkdnd: ...@python.org/msg00448.html">http://ww
+w.mail-archive.com/tkin...@python.org/msg00448.html
#Write the script and add some lines to help PerlApp find the tkdnd pa
+ckage
#Note 2 on helping PerlApp to find tkdnd with Tkx::lappend: http://www
+.nntp.perl.org/group/perl.tcltk/2008/11/msg187.html
######################################################################
+#############
Tkx::lappend('::auto_path', $main::myactive.'\tkx_extra\tkdnd2.6');
Tkx::package_require('tkdnd');
######################################################################
+#############

my %elist;    # used to tell if item in list already and so a dup 
my %estate;   # used to keep disk state of item  
my @astate=();# used to keep display state of listbox array item  
my @aitem=(); # full name of an listbox array item

my $topdir='<no topdir>'; 
my $flagfiles='1'; 

my $item_colors={}; 
$item_colors->{'dup'}   ={background       =>'red'
                         ,selectbackground =>'pink'
                         ,selectforeground =>'black'
                         }; 
$item_colors->{'file'}  ={background       =>'#74BBFB' #blue ice    
                         ,selectbackground =>'#7F00FF' # medium slateb
+lue2
                         ,selectforeground =>'white'
                         }; 
$item_colors->{'dir'}   ={background       =>'white'
                         ,selectbackground =>'blue'
                         ,selectforeground =>'white'
                         }; 

$item_colors->{'err'}   ={background       =>'#DDA0DD' # plum 
                         ,selectbackground =>'blue'
                         ,selectforeground =>'white'
                         }; 


my $statustext='Status here'; 
my $status_good=0; 
my $status_dup =0; 
my $status_err =0; 
my $status_file=0; 
update_status(); 


####### start tkx 
my $mw = Tkx::widget->new(".");

$mw->g_wm_title("Drag/drop queuer");
$mw->g_wm_geometry("600x200-30+40");



########################## menu ###############
Tkx::option_add("*tearOff", 0); # http://www.tkdocs.com/tutorial/menus
+.html

my $m = $mw->new_menu;
$mw->configure(-menu => $m);

my $mfile = $m->new_menu;
$m->add_cascade(-menu => $mfile, -label => "File");
$mfile->add_command(-label => "Exit"     , -command => sub {exit;});
$mfile->add_command(-label => "Write"    , -command => sub {writelist(
+);});

my $medit = $m->new_menu;
$m->add_cascade(-menu => $medit, -label => "Edit");
$medit->add_command(-label => "Clean Dup" ,   -command => sub {cleanli
+st('dup')});
$medit->add_command(-label => "Clean File",   -command => sub {cleanfi
+les()});
$medit->add_command(-label => "Clean Sel" ,   -command => sub {cleanse
+lection()});
$medit->add_command(-label => "Clean Errors", -command => sub {cleanli
+st('err')});
$medit->add_separator;
$medit->add_command(-label => "Paste",        -command => sub {paste()
+});

my $mhelp = $m->new_menu;
$m->add_cascade(-menu => $mhelp, -label => "Help");
$mhelp->add_command(-label => "About", -command => sub {about()});


############### top frame ###################

my $w_tfrm = $mw->new_ttk__frame();
$w_tfrm->configure(-borderwidth => 2, -relief => "sunken");

my $w_tnam = $w_tfrm->new_label(-text         =>"Topdir"
                               ,-justify      =>'left'
                               ,-anchor       =>'nw'
                               ,-background   =>'#CDCDCD'
                               );
$w_tnam->g_grid(-column => 0, -row => 0, -sticky => "w");            
#$w_tnam->g_pack(qw '-fill none -expand no -anchor nw');

my $w_tdir = $w_tfrm->new_label(-textvariable =>\$topdir
                               ,-justify      =>'left'
                               ,-anchor       =>'nw'
                               ,-background   =>'#CDCDCD'
                               );
$w_tdir->g_grid(-column => 1, -row => 0, -sticky => "e");            

# drag and trop to anywhere in frame 
Tkx::tkdnd__drop___target_register($w_tfrm,'*');
Tkx::bind ($w_tfrm, '<<Drop:DND_Files>>', 
   [ sub {topdir_dnd(@_);} , Tkx::Ev("%D") ] 
   );

$w_tfrm->g_pack(qw '-fill x -expand no');


################# bot frame ############### 

my $w_bfrm = $mw->new_ttk__frame();
$w_bfrm->configure(-borderwidth => 2, -relief => "groove");

my $w_elab = $w_bfrm->new_label(-text=>"Entrys:"
                               ,-justify=>'left'
                               ,-anchor=>'nw'
                               );
$w_elab->g_grid(-column => 0, -row => 0, -sticky => "we");


my $lb = $w_bfrm->new_tk__listbox(-height => 3, -selectmode=>'extended
+');
$lb->g_grid(-column => 0, -row => 1, -sticky => "nwes");

my $sv = $w_bfrm->new_ttk__scrollbar(-command => [$lb, "yview"], 
        -orient => "vertical"); 
$sv->g_grid(-column =>1, -row => 1, -sticky => "ns");

my $sh = $w_bfrm->new_ttk__scrollbar(-command => [$lb, "xview"], 
        -orient => "horizontal"); 
$sh->g_grid(-column =>0, -row => 2, -sticky => "ew");

$lb->configure(-yscrollcommand => [$sv, "set"]);
$lb->configure(-xscrollcommand => [$sh, "set"]);

($w_bfrm->new_ttk__label(-textvariable => \$statustext, 
                        -anchor => "w"))
        ->g_grid(-column => 0, -row => 3, -sticky => "we");

$w_bfrm->g_grid_columnconfigure(0, -weight => 1); 
$w_bfrm->g_grid_rowconfigure   (1, -weight => 1);


$w_bfrm->g_pack(qw '-fill both -expand true');

# drop anywhere in the frame 
Tkx::tkdnd__drop___target_register($w_bfrm,'*');
Tkx::bind ($w_bfrm
          , '<<Drop:DND_Files>>'
          , [ sub{ drop_to_list(@_) } , Tkx::Ev("%D")] 
          );
Tkx::bind ('all' # $w_bfrm
          , '<Control-a>'
          ,  sub{ ctrl_a() }  
          );
Tkx::bind ('all' # $w_bfrm
          , '<Control-v>'
          ,  sub{ paste() }  
          );

################# button/cmd frame ############### 

my $w_cfrm = $mw->new_ttk__frame();

my $c_dirs = $w_cfrm->new_ttk__checkbutton(-text => "Flag Files"
                                          , -command  => sub {flagfile
+schanged()}
                                          , -variable => \$flagfiles
                                          , -onvalue  => "1"
                                          , -offvalue => "0"
                                          );
$c_dirs->g_grid(-column =>0, -row => 0, -sticky => "ew");


#my $b_cleand = $w_cfrm->new_ttk__button(-text => "CleanDup" 
#                                       , -command => sub {cleanlist('
+dup');}
#                                       , 
#                                       );
#$b_cleand->g_grid(-column=>91,-row => 0, -sticky => "ew");
#my $conf=$b_cleand->configure(); print $conf."\n";
#$b_cleand->configure();

sub makecolorbutton{ 
# ttk button with a colored label wrapped in a frame 
  my $in=shift; 
  my $text=shift; 
  my $textlab=shift; 
  my $col=shift; 
  my $row=shift; 
  my $color=shift; 
  my $sub=shift; 

  my $w_cfrm = $in->new_ttk__frame();

  my $w_tdir = $w_cfrm->new_label(-text          =>$textlab
                                 ,-justify      =>'left'
                                 ,-anchor       =>'nw'
                                 ,-background   =>$color
                               );
  $w_tdir->g_grid(-column => 1, -row => 0, -sticky => "ew");          
+  

  my $b_cleand = $w_cfrm->new_ttk__button(-text => $text , -command =>
+ $sub );
  $b_cleand->g_grid(-column=>1,-row =>2, -sticky => "ew");

#  my $w_tdir2 = $w_cfrm->new_label(-text        =>$text
#                                 ,-justify      =>'left'
#                                 ,-anchor       =>'nw'
#                                 ,-background   =>$color
#                               );
#  $w_tdir2->g_grid(-column => 1, -row => 3, -sticky => "ew");        
+    

  $w_cfrm->g_grid(-column=>$col,-row => $row, -sticky => "ew");

  } # makebutton 
makecolorbutton($w_cfrm
               ,"CleanDup"
               ,"Duplicate"
               ,92,0
               ,$item_colors->{dup}{background}
               ,sub {cleanlist('dup');}
               ); 



  makecolorbutton($w_cfrm
                 ,"CleanFile"
                 ,"File"
                 ,91,0
                 ,$item_colors->{file}{background}
                 ,sub {cleanfiles();}
                 ); 
  makecolorbutton($w_cfrm
                 ,"CleanErr"
                 ,"Errors"
                 ,93,0
                 ,$item_colors->{err}{background}
                 ,sub {cleanlist('err');}
                 ); 
  makecolorbutton($w_cfrm
                 ,"CleanSel"
                 ," "
                 ,94,0
                 ,'White'
                 ,sub {cleanselection();}
                 ); 
  makecolorbutton($w_cfrm
                 ,"Paste"
                 ,"  Clipboard "
                 ,111,0
                 ,'White'
                 ,sub {paste();}
                 ); 
  makecolorbutton($w_cfrm
                 ,"Write"
                 ,"         File "
                 ,199,0
                 ,'White'
                 ,sub {writelist();}
                 ); 


  $w_cfrm->g_pack(qw '-fill both -expand false');




  Tkx::MainLoop;
  exit; 
########################################################
sub cleanselection {
# remove selected items from list 
  my $sel0=$lb->curselection(); 
  for my $row (split(' ',$sel0)) {$astate[$row]='sel';} 
  cleanlist('sel');  
  } #cleanselection 

sub cleanfiles {
# remove file items from list 
  my $row=0; 
  for my $item (@aitem) { 
    if ($estate{$item} eq 'file' ){ $astate[$row]='file';} 
    $row++;
    }
  cleanlist('file');  
  } #cleanfiles 

sub cleanlist{ 
  # clean the list of a astate type 
  my $test=shift; 
  $test='dup' unless ($test); 
  my @good; 

# exclude the ones of the type 
  my $row=0; 
  for my $type (@astate) { 
          if ($type ne $test) { 
              my $item=$aitem[$row]; 
              push @good,$item;
              }
    $row++;
    }

# clear stuff 
  %elist={}; 
  @astate=(); 
  @aitem=(); 
  $status_dup =0; 
  $status_good=0; 
  $status_file=0; 
  $status_err =0; 

  $lb->delete(0,'end'); 

  if (1 eq 1 ) { # new way 
    %estate={}; 
    add_list(@good); 
    } 
  else { # oldway 

# put them back in the list 
  $row=0; 
  for my $item (@good) {
      my $type=$estate{$item}; 
      if ($elist{$item}) {$type='dup';$status_dup++;}
        else {
          $elist{$item}=1; 
          if ($type eq 'dir') {    $status_good++; }
          elsif ($type eq 'dir') {    $status_good++; }
            else {$status_file++};
          } 
      $lb->insert("end", $item);
      set_item($lb,$row,$type); 
      $astate[$row]=$type; 
      $aitem[$row]=$item; 
      $row++;
      } # item good 

  update_status(); 
  } #old way 

  }#cleanlist 

sub update_status{ 

  $statustext='Status Dirs:'.$status_good
             .' Files:'.$status_file
             .' Dups:' .$status_dup
             .' Err:'  .$status_err
             ; 

  } # update_status 

sub drop_to_list { 

      my $droplist = shift;
      my @list = Tkx::SplitList($droplist); # can be a tcl array 
      add_list(@list); 
  } #drop_to_list 

sub add_list{ 
      my @list=@_; 
      my $row=$lb->index('end'); 
      for my $item (@list) {
        my $type;
        $lb->insert("end", $item);
        if ($elist{$item}){ 
            $type='dup'; 
            $status_dup++;
            }
          else { 
# an err is probably a file/dir that disapeared since it was dropped i
+n 
            $elist{$item}=1; 
            if(    -d $item ) { $type='dir';  $status_good++; } 
            elsif( -f $item ) { $type='file'; $status_file++; } 
            else              { $type='err';  $status_err++; } 
            $estate{$item}=$type; 
            };
        $astate[$row]=$type;  
        $aitem [$row]=$item;  
        set_item($lb,$row,$type); 
        $row++; 
#        $lb->see('end');
        } # item list 

  update_status(); 
} # addlist 


sub set_item { 
  # set the display attrs of an item 
  my $lb=shift; 
  my $row=shift; 
  my $type=shift; 
  if ((!$flagfiles) && $type eq 'file') { $type='dir';} 

  $lb->itemconfigure($row
                    ,-background       => $item_colors->{$type}{'backg
+round'}
                    ,-selectbackground => $item_colors->{$type}{'selec
+tbackground'}
                    ,-selectforeground => $item_colors->{$type}{'selec
+tforeground'}
                    );

  }#set item 


sub about {
# need to geom this to a good place 
# and  get it in focus 

# -parent => $mw

  my $tl = $mw->new_toplevel();

  my $w_tfrm = $tl->new_ttk__frame();
  $w_tfrm->configure(-borderwidth => 2, -relief => "sunken");
  my $abouttext="About:\n\nBy:Huck\n\nClose with X"; 

  my $w_tnam = $w_tfrm->new_label(-textvariable=>\$abouttext
                                 ,-justify=>'left'
                                 ,-anchor=>'nw'
                                 );
  
  $w_tnam->g_pack(qw '-fill both -expand true -anchor nw');
  $w_tfrm->g_pack(qw '-fill both -expand true -anchor nw');

  } #about 

sub flagfileschanged {
  my $row=0; 
  for my $type (@astate) { 
    set_item($lb,$row,$type); 
    $row++;
    } # type astate 

 } # flagfiles 

sub writelist {
#  my $file=\*STDOUT;
  my $filename = Tkx::tk___getSaveFile(-parent => $mw
                                      ,-defaultextension => 'txt'
                                      );
 
  if ($filename) { 
      open (LIST,'>'.$filename) || die 'cant open for write:'.$filenam
+e; 
      my $file=\*LIST; 
      print $file '-topdir '.$topdir."\n"; 
      my $row=0; 
      for my $item (@aitem) { 
        print $file '-'.$astate[$row].' '.$item."\n"; 
        $row++; 
        }
    close LIST; 
    } # filename 
  } #writelist 

sub ctrl_a {
  $lb->selection_set(0,'end');
}

sub topdir_dnd{
          $topdir = shift;
#          print "topdir have '$topdir'\n";
          my @list = Tkx::SplitList($topdir); # can have more than one
+ 
                                              # only take last 
          my $e1=''; 
          for my $item (@list) { $e1=$item; }
          # should insure its a dir before accepting it 
          $topdir=$e1; 
        }


sub paste { 

  if (Win32::Clipboard::IsFiles()  ) { 
      my @files = Win32::Clipboard::GetFiles();
      my @dosfiles; 
      for my $f(@files){ $f=~s.\\./.g; push @dosfiles,$f} 
      add_list(@files); 
      } # isfiles 
  } # paste

[download]
"with a chainsaw", but it does work, you can drag and drop dirs of files from an explorer window into either the Topdir:($w_tfrm) or entries($w_bfrm) area.

does what i want, probably does more than you want, YMMV

In Section Seekers of Perl Wisdom