Beefy Boxes and Bandwidth Generously Provided by pair Networks
Pathologically Eclectic Rubbish Lister
 
PerlMonks  

want way to drag tk window

by redss (Monk)
on Aug 05, 2017 at 19:04 UTC ( [id://1196818]=perlquestion: print w/replies, xml ) Need Help??

redss has asked for the wisdom of the Perl Monks concerning the following question:

Hi Monks!

Given the simplest perl tk program, that simply calls MainWindow->new followed by MainLoop...

I can move the window by clicking the title bar and dragging it, but if I select "undecorate" for the window, then I don't have a title bar that I can use to drag it.

Is there a tk widget I can add inside the window that will enable me to drag the window using the widget, or clicking anywhere inside the window, so that I don't need the title bar for that?

Replies are listed 'Best First'.
Re: want way to drag tk window
by tybalt89 (Monsignor) on Aug 05, 2017 at 19:48 UTC

    Something like this?

    All you have to do is change the geometry :)

    #!/usr/bin/perl # http://perlmonks.org/?node_id=1196818 use strict; use warnings; use Tk; sub xy { $_[0]->XEvent->x, $_[0]->XEvent->y } my $mw = MainWindow->new; $mw->overrideredirect(1); $mw->Label( -text => 'Press 1, Move, then Release in green Canvas to move window +', )->pack(-fill => 'x'); my $c = $mw->Canvas(-width => 500, -height => 400, -bg => 'green', )->pack; $c->Tk::bind('<1>' => \&leftdown); $c->Tk::bind('<ButtonRelease-1>' => \&leftup); $mw->Button(-text => 'Exit', -command => sub { $mw->destroy }, )->pack(-fill => 'x'); MainLoop; my ($startx, $starty); sub leftup { my $oldposition = $mw->geometry; my ($endx, $endy) = &xy; my $deltax = $endx - $startx; my $deltay = $endy - $starty; my $newposition = $oldposition =~ s/\+\K(\d+)\+(\d+)$/ ($1 + $deltax) . '+' . ($2 + $deltay) /er; $mw->geometry( $newposition ); print "$newposition\n"; } sub leftdown { ($startx, $starty) = &xy; }
      Very nice tybalt89!

      One suggestion I'd offer is to trap the '<Motion>' event as well, to see the window move any time mouse button 1 is down (not just the final release).

      You can do that with these minor modifications to your solution:

      #!/usr/bin/perl # http://perlmonks.org/?node_id=1196818 use strict; use warnings; use Tk; # golux: flag to detect mouse button 1 pressed my $b_mouse1 = 0; sub xy { $_[0]->XEvent->x, $_[0]->XEvent->y } my $mw = MainWindow->new; $mw->overrideredirect(1); $mw->Label( -text => 'Press 1, Move, then Release in green Canvas to move window +', )->pack(-fill => 'x'); my $c = $mw->Canvas(-width => 500, -height => 400, -bg => 'green', )->pack; $c->Tk::bind('<1>' => \&leftdown); $c->Tk::bind('<Motion>' => \&motion); # golux: also detect Moti +on $c->Tk::bind('<ButtonRelease-1>' => \&leftup); $mw->Button(-text => 'Exit', -command => sub { $mw->destroy }, )->pack(-fill => 'x'); MainLoop; my ($startx, $starty); sub leftup { # golux: moved the "heavy lifting" into subroutine motion(); the # only thing we need do here is clear the mouse button 1 down flag. $b_mouse1 = 0; } sub leftdown { $b_mouse1 = 1; ($startx, $starty) = &xy; } sub motion { $b_mouse1 or return; my $oldposition = $mw->geometry; my ($endx, $endy) = &xy; my $deltax = $endx - $startx; my $deltay = $endy - $starty; # golux: Not enough to look for \d+, we need to look for [-\d]+, s +ince # the (X,Y) coordinates can also be negative my $newposition = $oldposition =~ s/\+\K([-\d]+)\+([-\d]+)$/ ($1 + $deltax) . '+' . ($2 + $deltay) / +er; $mw->geometry( $newposition ); print "$newposition\n"; }

      Instead of moving the window at the end, this moves it any time motion is detected; the only thing needed when mouse button 1 is released is to clear the flag $b_mouse1.

      I should elaborate on one thing -- when I tested this (in Windows) I noticed that dragging the window too far up or left caused it to become "stuck". The reason turned out that the one (or both) of the (X, Y) coordinates were negative, which needed to be checked for in your regex to overcome that problem.

      say  substr+lc crypt(qw $i3 SI$),4,5
        Awesome, thanks to both of you!

        I should mention, the code works on linux but not windows, I get a syntax error only on windows, strange:

        Unrecognized escape \K passed through at c:\t\junk32.pl line 58. Bareword found where operator expected at c:\t\junk32.pl line 58, near + "s/\+\K([-\d]+)\+([-\d]+)$/ ($1 + $deltax) . '+' . ($2 + $deltay) /e +r" syntax error at c:\t\junk32.pl line 58, near "s/\+\K([-\d]+)\+([-\d]+) +$/ ($1 + $deltax) . '+' . ($2 + $deltay) /er"
Re: want way to drag tk window
by zentara (Archbishop) on Aug 06, 2017 at 11:56 UTC
    Hi, here is another variation which is simple to see what happens.
    #!/usr/bin/perl use warnings; use strict; use Tk; my $mw = tkinit; $mw->geometry('200x200+200+200'); $mw->overrideredirect(1); my %wdraginfo; $mw->bind('<ButtonPress-1>', sub{ my $xe = $mw->XEvent; $wdraginfo{xoff} = $mw->pointerx - $mw->rootx; $wdraginfo{yoff} = $mw->pointery - $mw->rooty; }); $mw->bind('<B1-Motion>', sub{ my ($x,$y); $x=$mw->pointerx-$wdraginfo{xoff}; $y=$mw->pointery-$wdraginfo{yoff}; $mw->geometry($mw->width."x".$mw->height."+$x+$y"); }); MainLoop;

    I'm not really a human, but I play one on earth. ..... an animated JAPH
      This is the best solution since it works fine in all my versions of perl, and it is very simple. Thanks! I'm curious why all solutions make the window "always on top" though.
        In Tk, overrideredirect removes decorations and puts the window on top across all your virtual desktops with a global grab, it's not the best thing. In Gtk2, you can get more control, where you can remove decorations and set global_grab separately.

        I'm not really a human, but I play one on earth. ..... an animated JAPH
Re: want way to drag tk window
by Anonymous Monk on Aug 05, 2017 at 19:36 UTC
    IIRC there is no tk draggable widget premade , but it should be easy to write

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: perlquestion [id://1196818]
Approved by stevieb
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others imbibing at the Monastery: (6)
As of 2024-03-28 08:23 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found