use strict; use FindBin; use lib "$FindBin::Bin"; use Tk; use Tk::HList; use Tk::JPEG; use Tk::DragDrop; use Tk::DropSite; use Tk::Photo; use Tk::ItemStyle; ############ # globals my ($mw); my $hlRes; my $hlDocRout; my $hlDocType; my $dnd_token; my @ImgArr; my $TextOver; DoMain(); =pod layout =cut sub DoMain { # main window $mw = MainWindow->new; $mw->title("Work Flow Routing"); #$mw->configure(-width => 1200, height => 600); # toolbar TODO add frame and left justify $mw->Button(-text => "info", -command => \&Info)->pack(-side => "top", -anchor => "w"); # Doc type list $hlDocType = $mw->Scrolled("HList", -itemtype => 'text', -selectmode => 'browse', -height => 50, -width => 20, -scrollbars => 'osoe', )->pack(-side => 'left', -expand => 1, -fill => 'both'); # load document types my @DocTypes = qw(PurchaseOrder CustomerOrder); for my $t (@DocTypes) { my $e=$hlDocType->addchild(""); $hlDocType->itemCreate($e, 0, -itemtype => "text", -text => $t, ); } # picture routing and resource lists $hlDocRout = $mw->Scrolled("HList", -itemtype => 'image', -selectmode => 'browse', -browsecmd => \&OnClick, -height => 50, -width => 20, -scrollbars => 'osoe', )->pack(-side => 'left', -expand => 1, -fill => 'both'); $hlRes = $mw->Scrolled("HList", -itemtype => 'image', -selectmode => 'browse', -browsecmd => \&OnClick, -height => 50, -width => 20, -scrollbars => 'osoe', )->pack(-side => 'right', -expand => 1, -fill => 'both'); $TextOver=$hlRes->ItemStyle("imagetext", -textanchor => "n"); # drag and drop stuff $dnd_token = $hlRes->DragDrop (-event => '', -sitetypes => ['Local'], -startcommand => sub { StartDrag($dnd_token) }, ); $hlDocRout->DropSite (-droptypes => ['Local'], -dropcommand => [ \&Drop, $hlDocRout, $dnd_token ], ); $hlDocRout->bind("", \&Delete); # load data for resource list my $i=0; for my $fn (glob ("*.jpg")) { my $SrcImg=$mw->Photo(-file => $fn); my $DstImg=$mw->Photo(); my $w=$SrcImg->width(); my $h=$SrcImg->height(); my $f=int($h/75); $DstImg->copy($SrcImg, -subsample => ($f, $f)); # rescales image to one size $i++; push @ImgArr, $DstImg; print "$i:$fn:$w $h\n"; $SrcImg->delete(); my $e=$hlRes->addchild("", -data => $fn,); $hlRes->itemCreate($e, 0, -itemtype => "imagetext", -image => $DstImg, -text => $fn, -style => $TextOver, ); } MainLoop; } sub StartDrag { my($token) = @_; my $w = $token->parent; # $w is the source listbox my $e = $w->XEvent; my $idx = $w->nearest($e->y); # get the listbox entry under cursor #print "y:", $e->y, "\n"; if (defined $idx) { # Configure the dnd token to show the listbox entry my $opt=$token->configure(); $token->configure(-image => $ImgArr[$idx]); $token->configure(-text => $w->info("data", $ idx)); # Show the token my($X, $Y) = ($e->X, $e->Y); $token->MoveToplevelWindow ($X, $Y); $token->raise; $token->deiconify; $token->FindSite($X, $Y, $e); #print "$token\n"; } } # Accept a drop and insert a new item in the destination listbox. sub Drop { my($hlist, $dndtoken) = @_; # token info my $img = $dndtoken->cget(-image); my $text = $dndtoken->cget(-text); #print "image:$img\n"; #my @list=$hlist->info("children"); # get position to insert or append at my $end = ($hlist->info("children"))[-1]; my @pos = (-after => $end) if defined $end; my $y = $hlist->pointery - $hlist->rooty; my $nearest = $hlist->nearest($y); if (defined $nearest) { my(@bbox) = $hlist->infoBbox($nearest); if ($y > ($bbox[3]-$bbox[1])/2+$bbox[1]) { @pos = (-after => $nearest); } else { @pos = (-before => $nearest); } } # add the line my $fn=""; my $e=$hlist->addchild("", @pos, -data => $fn); $hlist->itemCreate($e, 0, -itemtype => "imagetext", -image => $img, -text => $text, -style => $TextOver, ); $hlist->see($e); } sub Delete { my ($w) = @_; my @sl=$hlDocRout->info("selection"); print "got delete: $w, selected: @sl\n"; $hlDocRout->delete("entry", @sl) if ($#sl >= 0); } sub OnClick { my $entry=shift; my $data=$hlRes->info("data", $entry); my $val=$hlRes->entrycget($entry, "-image"); my $d=$hlRes->entrycget($entry, "-data"); my @l=$hlRes->info("children"); my $i=$entry-1; my $h=$ImgArr[$i]->height(); my $t=$ImgArr[$i]->type(); my $f=$ImgArr[$i]->cget("-file"); #my $d=$ImgArr[$i]->cget("-data"); =pod print "$entry:$data\n"; print "image:$val\n"; print "height:$h\n"; print "type:$t\n"; #print "size:$#l\n"; #print "filename:$f\n"; print "data:$d\n"; my @opt=$hlRes->entryconfigure($entry); $#opt; =cut =pod for my $a (@opt) { print "$a\n"; print "@$a\n"; #for $b (@$a) { # my $val=$hlRes->entryconfigure($entry, $b); # print "$b:$val\n"; #} } =cut } sub Info { my @il=$mw->imageNames; for my $a (@il) { my $h=$a->height; my $type=$a->type; print "$a:$h:$type\n"; }