Beefy Boxes and Bandwidth Generously Provided by pair Networks
Your skill will accomplish
what the force of many cannot

Tk Drag and Drop between TList widgets

by hiseldl (Priest)
on Jul 21, 2002 at 01:56 UTC ( [id://183718]=CUFP: print w/replies, xml ) Need Help??

I wrote this for another monk, but everyone should be able to use it. I've factored out the list generation methods that are used to populate the lists, so it should be easy to change it.

It's not a fully functional application, so I'm putting it in snippets. It is also an example of how to use DND between to TList widgets.


#! perl -w # This script will create two windows, the one on # the left is where all the directories will be # displayed and on the right is where the users # or groups that have access to the directory will # be displayed. # 1-On the right windows, displaying users and # groups as Icons (like an icon with a drawing # of face for a users and two faces for a group # similar to what you get in User Manager) instead # of displaying them in text. # 2- Clicking on a user icon and dragging it # then dropping it on an icon representing a # group will move the user to that group. # 3- On the left Window, where the directory # structures are displayed, I would like to have # a display similar to what you get if you had # used Tk::DirTree -if I can. Also a single click # on a directory will display the user permissions # on the right window (which the script does that # anyway) and double click will assign a variable # to the selected path, so I can do other things # with that path. # 4- Instead of passing the path as @ARGV, it # would be better if I could have an entry field # (in the top left hand corner of the window) where # I can pass the path in there and bind the Enter # (or Return) key to that field. use strict; use Tk 800.005; use Tk::TList; use Tk::DirTree; use Tk::Frame; use Tk::Scrollbar; use Tk::Adjuster; # These are required for drag-n-drop operations use Tk::DragDrop; use Tk::DropSite; use File::Find; use Win32::Perms; # $tk{widget_refs}, $dr{data_refs}, $im{image_refs} use vars qw/%tk %dr %im @users @groups $dnd_token/; $dr{PATH} = shift @ARGV || "."; $dr{perms} = "Permissions: ".$dr{PATH}; $tk{mw} = MainWindow->new(-background => 'white'); $tk{mw}->geometry('500x400'); $tk{top_frame} = $tk{mw}->Frame; $tk{left_frame} = $tk{mw}->Frame; $tk{adjuster} = $tk{mw}->Adjuster(-widget=> $tk{left_frame}, -side= +>'left'); $tk{right_frame} = $tk{mw}->Frame; $tk{entry_box} = $tk{top_frame}->Entry(-textvariable=>\$dr{PATH}); $tk{dir_tree} = $tk{left_frame}->Scrolled('DirTree', -height=>'0', -width=>'0', -scrollbars=>'e', ); $tk{output_list} = $tk{right_frame}->Scrolled('TList', -height=>'1', -width=>'1', -scrollbars=>'osoe',); $tk{user_list} = $tk{right_frame}->Scrolled('TList', -height=>'1', -width=>'1', -scrollbars=>'osoe',); $tk{group_list} = $tk{right_frame}->Scrolled('TList', -height=>'1', -width=>'1', -scrollbars=>'osoe',); $tk{user_label} = $tk{right_frame}->Label(-text => "User List:"); $tk{group_label} = $tk{right_frame}->Label(-text => "Group List:"); $tk{output_label} = $tk{right_frame}->Label(-textvariable => \$dr{perm +s}); $im{ONE} = $tk{mw}->Photo(-file => 'one.gif'); $im{GROUP} = $tk{mw}->Photo(-file => 'group.gif'); $tk{dir_tree}->chdir( $dr{PATH} ); $tk{dir_tree}->bind('<ButtonRelease-1>',sub {get_perms();}); $tk{entry_box}->bind('<Key-Return>',sub {OnNewPath();}); $tk{top_frame}->pack(qw/-side top -fill x/); $tk{left_frame}->pack(qw/-side left -fill y/); $tk{adjuster}->pack(qw/-side left -fill y/); $tk{right_frame}->pack(qw/-side right -fill both -expand 1/); $tk{entry_box} ->pack(qw/-side top -fill both -expand 1/); $tk{dir_tree} ->pack(qw/-side left -fill both -expand 1/); $tk{output_label}->pack(qw/-side top -fill both/); $tk{output_list} ->pack(qw/-side top -fill both -expand 1/); $tk{user_label} ->pack(qw/-side top -fill both/); $tk{user_list} ->pack(qw/-side top -fill both -expand 1/); $tk{group_label} ->pack(qw/-side top -fill both/); $tk{group_list} ->pack(qw/-side top -fill both -expand 1/); # Define the source for drags. # Drags are started while pressing the left mouse button and moving th +e # mouse. Then the StartDrag callback is executed. # # The DragDrop method returns a "token", which is a Label widget for # the text or image displayed during the drag action. $dnd_token = $tk{user_list}->DragDrop (-event => '<B1-Motion>', -sitetypes => [qw/Local/], -startcommand => \&DragStart, ); # Define the target for drops. $tk{group_list}->DropSite (-droptypes => [qw/Local/], -dropcommand => [\&Drop, $tk{group_list}, $dnd_token ], ); # Add the users to the user list and the groups to the group list @users = @{&GetUsers()}; map { $tk{user_list}->insert('end', -itemtype=>'imagetext', -text=>"$_", -image=>$im{ONE}) } @users; @groups = @{&GetGroups()}; map { $tk{group_list}->insert('end', -itemtype=>'imagetext', -text=>"$_", -image=>$im{GROUP}) } @groups; MainLoop; exit 0; sub DragStart { my($token) = @_; my $w = $token->parent; # $w is the source listbox my $e = $w->XEvent; my $idx = $w->GetNearest($e->x, $e->y); # get the listbox entry un +der cursor if (defined $idx) { # Configure the dnd token to show the listbox entry $token->configure(-text => $w->entrycget($idx, '-text') ); # Show the token my($X, $Y) = ($e->X, $e->Y); $token->MoveToplevelWindow($X, $Y); $token->raise; $token->deiconify; $token->FindSite($X, $Y, $e); } } # Accept a drop and insert a new item in the destination sub Drop { my($lb, $dnd_source) = @_; my $user_item = $dnd_source->cget('-text'); # figure out where in the group listbox the drop occurred my $y = $lb->pointery - $lb->rooty; my $x = $lb->pointerx - $lb->rootx; my $nearest = $lb->nearest($x,$y); if (defined $nearest) { my $group_item = $lb->entrycget($nearest, '-text'); &AddUserToGroup($user_item, $group_item); $lb->see($nearest); } } sub get_perms { # my ($indx) = $tk{dir_tree}->curselection(); my $path = $tk{dir_tree}->selectionGet(); &ShowPathInfo($path); } # This method is bound to the 'enter' key so that we can update # the path information from the entry widget. sub OnNewPath { $tk{dir_tree}->chdir( $dr{PATH} ); &ShowPathInfo( $dr{PATH} ); } sub ShowPathInfo { my ($path) = @_; my $perms = new Win32::Perms($path) || die "\n$^E\n"; print "Path: " . $perms->Path(); my $counter = $perms->Get(\ my @list); $dr{perms} = "Permisssions: $path"; $tk{output_list}->delete('0.1','end'); $tk{output_list}->insert('end', -itemtype=>'text', -text=>"$path"); foreach my $item (@list) { while (@_ = each %$item) { next unless $_[0] =~ /account|access/i; $tk{output_list}->insert('end', -itemtype=>'imagetext', -text=> $_[0].":". $_[1], -image=>$im{ONE}); } } } sub GetUsers { return [qw/One Two Three/]; } sub GetGroups { return [qw/Blue Green Red/]; } sub AddUserToGroup { my ($user, $group) = @_; # # Do something with $user_item and with $group_item # $dr{perms} = "User $user added to $group"; }

Log In?

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: CUFP [id://183718]
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others musing on the Monastery: (3)
As of 2024-07-23 14:46 GMT
Find Nodes?
    Voting Booth?

    No recent polls found

    erzuuli‥ 🛈The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.