"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]

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

...I just need help in getting all of the widgets and or additional ones in one window....

Hi,

Its real simple, if you're using the no-tcl-Eval version, well there is nothing mysterious there, just "pack" whatever extra widgets you want in the mainwindow ( $mw->Label... $mw->Listbox... ->pack )

If you're using the tcl-eval version, pay attention to this part

# 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...');
[download]

Do you get it now? All you have to do is

my $mw = $int->widget( ... ,'MainWindow');
$mw->Button(-text => 'freedom' )->pack;
[download]

The ... part is a secret, you have to read tcl tk docs to find out what it is