Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"
 
PerlMonks  

comment on
( [id://3333]=superdoc: print w/replies, xml ) Need Help??
The Tk Canvas widget is perfect for this in terms of simplicity. See the examples below. The Tk::Zinc and Gtk2's Goo Canvas have much better transparency, and zooming abilities, but they are harder to setup and use. But in general, go with a canvas type widget, as it allows you to lay down an image, then drag and place things anywhere you want on top. It is all done with "tags" as shown in the examples below. Also see Goo Canvas and transparent images

The big obstacle you will face is making your image resizable when the user resizes the window. You pretty much need to rebuild the resized image as the user finishes the resize. The Goo::Canvas has a nice zoom ability to get around this problem, see it's demo for how it works. Otherwise, just make a decent sized image and place it in a scrolled canvas, and let the scrollbars handle window resizes. :-)

Draggable xpm on Tk canvas demo, you could make a pushpin xpm. :-) 
#!/usr/bin/perl
use strict;
use warnings;
use Tk;
# Main window with a stretchy canvas...
my $mw = new MainWindow( -title => "Tk Canvas Item Drag" );
my $c = $mw->Canvas(
    -width  => 600,
    -height => 300,
    -bg     => 'beige',
)->pack( -expand => '1', -fill => 'both' );
# Some rectangle items...
$c->createRectangle(
    100, 100, 200, 200,
    -fill          => 'orange',
    -activefill    => 'darkorange',
    -outline       => 'red',
    -activeoutline => 'green',
    -width         => 1,
    -activewidth   => 2,
    -tags          => ['draggable'],
);
$c->createRectangle(
    210, 110, 260, 160,
    -fill       => 'red',
    -activefill => 'darkred',
    -tags       => ['draggable'],
);
# This one is not draggable...
$c->createRectangle(
    410, 90, 510, 160,
    -fill       => 'blue',
    -activefill => 'navy',
);
# An image of a playing card - loaded from a a pixmap with the playing
+_card_xpm sub - see below...
$c->Pixmap( 'card', -data => playing_card_xpm() );
$c->createImage(
    300, 100,
    -image  => 'card',
    -anchor => 'nw',
    -tags   => [ 'draggable', 'card' ],
);
my $description = <<'EOF';
The orange and red rectangles can be moved - the blue one can't.
When the playing card is dragged it leaves a vector behind!
Take a look at the info that goes to STDOUT.
EOF
$c->createText(
    300, 20,
    -anchor  => 'n',
    -justify => 'center',
    -text    => $description
);
# add bindings for draggable objects...
$c->bind( 'draggable', '<1>'                   => \&drag_start );
$c->bind( 'draggable', '<B1-Motion>'           => \&drag_during );
$c->bind( 'draggable', '<Any-ButtonRelease-1>' => \&drag_end );
# the enter and leave events could be used to show and hide highlight 
+type objects...
$c->bind( 'draggable', '<B1-Enter>' => undef );
$c->bind( 'draggable', '<B1-Leave>' => undef );
# Dragging item info hash to be kept during a drag...
my %draginfo;
MainLoop();

sub drag_start {
    print "drag_start:\n";
    my ($c) = @_;
    my $e = $c->XEvent;
    # get the screen position of the initial button press...
    my ( $sx, $sy ) = ( $e->x, $e->y,,, );
    print "\t screen: $sx, $sy\n";
    # get the canvas position...
    my ( $cx, $cy ) = ( $c->canvasx($sx), $c->canvasy($sy) );
    print "\t canvas: $cx, $cy\n";
    # get the clicked item...
    my $id = $c->find( 'withtag', 'current' );
    print "\t item id: $id\n";
    my ( $x1, $y1, $x2, $y2 ) = $c->bbox($id);
    print "\t obj has bbox: $x1, $y1, $x2, $y2.\n";
    # set up the draginfo...
    $draginfo{id}     = $id;
    $draginfo{startx} = $draginfo{lastx} = $cx;
    $draginfo{starty} = $draginfo{lasty} = $cy;
}

sub drag_during {
    print "drag_during:\n";
    my ($c) = @_;
    my $e = $c->XEvent;
    # get the screen position of the move...
    my ( $sx, $sy ) = ( $e->x, $e->y,,, );
    print "\t screen: $sx, $sy\n";
    # get the canvas position...
    my ( $cx, $cy ) = ( $c->canvasx($sx), $c->canvasy($sy) );
    print "\t canvas: $cx, $cy\n";
    # get the amount to move...
    my ( $dx, $dy ) = ( $cx - $draginfo{lastx}, $cy - $draginfo{lasty}
+ );
    print "\t dx, dy = $dx, $dy\n";
    # move it...
    $c->move( $draginfo{id}, $dx, $dy );
    # update last position
    $draginfo{lastx} = $cx;
    $draginfo{lasty} = $cy;
    my ( $x1, $y1, $x2, $y2 ) = $c->bbox( $draginfo{id} );
    print "\t obj has bbox: $x1, $y1, $x2, $y2.\n";
}

sub drag_end {
    print "drag_end: \n";
    # upon drag end, check for valid position and act accordingly...
    # was it the card?
    my @tags = $c->gettags( $draginfo{id} );
    if ( grep /^card$/, @tags ) {
        # did it move anywhere? If so draw a vector...
        if (   $draginfo{startx} - $draginfo{lastx}
            or $draginfo{starty} - $draginfo{lasty} )
        {
            my $line = $c->createLine(
                $draginfo{startx}, $draginfo{starty},
                $draginfo{lastx},  $draginfo{lasty},
                -arrow    => 'last',
                -width    => 3,
                -capstyle => 'round',
                -fill     => 'navy',
            );
        }
    }
    %draginfo = ();
}
# return the source of a nice playing card pixmap...
sub playing_card_xpm {
    return <<'EOXPM';
/* XPM */
static char *j[] = {
/* width height num_colors chars_per_pixel */
"    73    97        8            1",
/* colors */
"` c #000000",
". c #808080",
"# c #c0c0c0",
"a c None",
"b c #ffffff",
"c c #000000",
"d c #000000",
"e c #000000",
/* pixels */
"a#```````````````````````````````````````````````````````````````````
+``#a",
"#.bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb
+bb.#",
"`bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbb````bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbb.``.bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbb``bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbb``bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbb``bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbb``bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbb``bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbb``bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbb`#bb``bbbbbbbbbbbbbbbbbbbbb#.`````..#bbbbbbbbbbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbb``bb``bbbbbbbbbbbbbbbbbbb#.```````````#bbbbbbbbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbb.````.bbbbbbbbbbbbbbbbbb.``````````````.bbbbbbbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbb.``.bbbbbbbbbbbbbbbbbb#`````````````.```bbbbbbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbbb#`````````````..```.bbbbbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbbb.`````````````...```#bbbbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbbb````````````````````.bbbbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbb#`````````````````````#bbbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbb#`````````````````````.bbbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbb.``````````````````````bbbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbb.````````````...```````bbbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbb#``.#.``````..##.``````#bbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbb.``##b#````##b#b.``````#bbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbb#`.#.#b.```#b..#b.`````.bbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbb#`.``.#.``.b.``.##`````#bbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbb#`..`..#```#.```#b`````.bbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbb#``.``.....#````#b`````#bbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbbb``#.`######..`.##`````.bbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbbb``..############``````.bbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbbb``..####b#######.``````bbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbbb`..#######b#####.``````bbbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbbb``.####b######.#.``````#bbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbbb``..###########..``.```.bbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbbb``...#######.....``...``bbbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbbb.`#....#.#....###```..``.bbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbbb.`##........##bbb.```.```bbbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbb.``###.....####bbb#```````.bbbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbb#```bb#########bbbbb.```````#bbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbb```#bb#######bbbbbbbb````````bbbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbb.``.bbbb####bbbbbbbbbb.```````.bbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbb#```bbbbbbb#bbbbbbbbbbb#````````bbbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbb```.bbbbbbbbbbbbbbbbbbbb.````````bbbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbb.```bbbbbbbbbbbbbbbbbbbbb.`````````bbbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbb.```.##bbbbbb#bbbbbbbb#b#b#`````````.bbbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbb.````..b#bbb#b#bbbb#b######b``````````#bbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbb`````.#b#bbbbbbbbbbbbb#b###b#``````````bbbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbb#````.#bbbbbbb#bbbbbbbbbbbb##b.`````````#bbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbb.````##bbbbbbbbbbbbbbbbbbbbb###``````````bbbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbb````.#bbbbbbbbbbbbbbbbbbbbbbbb#.`````````#bbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbbb````#bbbbbbbbbbbbbbbbbbbbbbbbbb#``.``````.bbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbb.```.#bbbbbbbbbbbbbbbbbbbbbbbbbbb`.``.`````bbbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbbb````.bbbbbbbbb#bbbbbbbbbbbbbbbbbb.`````````#bbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbb.````bbbbbbbbbb#bbbbbbbbbbbbbbbbbb.`````````.bbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbbb.```.bbbbbbbbb#bbbbbbbbbbbbbbbbbbb.``````````bbbbbbbb
+bbb`",
"`bbbbbbbbbbbbbb#````#bbbbbbbbb#bbbbbbbbbbbbbbbbbbb.``````````#bbbbbbb
+bbb`",
"`bbbbbbbbbbbbbb.````#bbbbbbbbb#bbbbbbbbbbbbbbbbbbb#``````````.bbbbbbb
+bbb`",
"`bbbbbbbbbbbbb.````.bbbbbbbbbb#bbbbbbbbbbbbbbbbbbb#``````````.bbbbbbb
+bbb`",
"`bbbbbbbbbbbbb``````#bbbbbbbbb#bbbbbbbbbbbbbbbbbbbb```````````bbbbbbb
+bbb`",
"`bbbbbbbbbbbb.```.`.bbbbbbbbbb#bbbbbbbbbbbbbbbbbbb#```````````bbbbbbb
+bbb`",
"`bbbbbbbbbbbb#````..#bbbbbbbbb#bbbbbbbbbbbbbbbbbbbb``````````.bbbbbbb
+bbb`",
"`bbbbbbbbbbbb.````..bbbbbbbbbb#bbbbbbbbbbbbbbbbbbb#``````````.bbbbbbb
+bbb`",
"`bbbbbbbbbbbb#`.#.`.bbbbbbbbbb#bbbbbbbbbbbbbbbbbbb#```````.``.bbbbbbb
+bbb`",
"`bbbbbbbbbbbbb####.`##bbbbbbbb#bbbbbbbbbbbbbbbb###.``````````.bbbbbbb
+bbb`",
"`bbbbbbbbbbbb######.`.#bbbbbbb#bbbbbbbbbbbbbbbb###b`````````.bbbbbbbb
+bbb`",
"`bbbbbbbbbbb#.######.`.#bbbbbbbbbbbbbbbbbbbbbbb####````````.##bbbbbbb
+bbb`",
"`bbbbbbbbbb#..#######```#bbbbbb#bbbbbbbbbbbbbbb###..``````.###bbbbbbb
+bbb`",
"`bbbbbbbb##.##########```#bbbbbbbbbbbbbbbbbbb#####..`````..###bbbbbbb
+bbb`",
"`bbbbb###.#.##########.```#bbbbbbbbbbbbbbbbbb#####........####bbbbbbb
+bbb`",
"`bbbb#.################````.#bbbbbbbbbbbbbbbb##.##.#.....######bbbbbb
+bbb`",
"`bbbb##################.````.bbbbbbbbbbbbbbbb##..##.#...########bbbbb
+bbb`",
"`bbbb###################`````bbbbbbbbbbbbbbbbb#..################bbbb
+bbb`",
"`bbbb###################.````#bbbbbbbbbbbbbbb##...################bbb
+bbb`",
"`bbbb#.##################.``#bbbbbbbbbbbbbbbb#`..##################bb
+bbb`",
"`bbbb#.####################bbbbbbbbbbbbbbbbb#``..###################b
+bbb`",
"`bbbb#####################.#bbbbbbbbbbbbbb#.```..###################b
+bbb`",
"`bbbb#.####################.bbbbbbbbbbbbb#`````..##################bb
+bbb`",
"`bbbb#####################...#bbbbbbbb##.``````.##################bbb
+bbb`",
"`bbbb..####################.``..#....``````````..#.##############bbbb
+bbb`",
"`bbbb#..#.################...`````````````````...###########.##bbbbbb
+bbb`",
"`bbbb#.........##########.#..``````````````````...##.#####..#bbbbbbbb
+bbb`",
"`bbbbbb#..........####.#....``````````````````..#..###.....#bbbbbbbbb
+bbb`",
"`bbbbbbbbbb#.................``..###########..`...#..#....bbbbbb.``.b
+bbb`",
"`bbbbbbbbbbbbb#........#...`.#bbbbbbbbbbbbbbbb.`.........bbbbbb.````.
+bbb`",
"`bbbbbbbbbbbbbbbbb#......`..bbbbbbbbbbbbbbbbbb#.`.......bbbbbbb``bb``
+bbb`",
"`bbbbbbbbbbbbbbbbbbb#..``.#bbbbbbbbbbbbbbbbbbbb#.```..#bbbbbbbb``bb#`
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb``bbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb``bbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb``bbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb``bbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb``bbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb``bbbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb.``.bbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb````bbb
+bbb`",
"`bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb
+bbb`",
"#.bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb
+bb.#",
"a#```````````````````````````````````````````````````````````````````
+``#a"
};
EOXPM
}

[download]

And you can add some balloons to your draggable object.

Balloons on draggable objects 

#!/usr/bin/perl
use strict;
use Tk;
use Tk::Balloon;

my $dx;
my $dy;
my $balloonhash = {};
my $statushash  = {};

my $mw        = tkinit;
my $c         = $mw->Canvas->pack;
my $statusbar = $mw->Label->pack( -fill => 'x' );

my $b = $c->Balloon(
    -initwait        => 0,
    -statusbar       => $statusbar,
    -balloonposition => 'mouse'
);

$b->attach(
    $c,
    -initwait      => 75,
    -balloonmsg    => $balloonhash,
    -statusmsg     => $statushash,
    -cancelcommand => \&checktag
);

for my $i ( 0 .. 4 ) {

    my $item = $c->create(
        'rect',
        $i * 20, $i * 20, $i * 20 + 20,
        $i * 20 + 20,
        -fill => 'red',
        -tags => ["TAF$i", 'group1', 'move']
    );

    $balloonhash->{$item} = "Balloon $i WITH tag";
    $statushash->{$item}  = "Status message $i WITH tag";


    my $item2 = $c->create(
        'rect', $i * 20 + 20,
        $i * 20,
        $i * 20 + 40,
        $i * 20 + 20,
        -fill => 'green',
    -tags => ['group2','move']
    );
    $balloonhash->{$item2} = "Balloon $i with NO tag";
    $statushash->{$item2}  = "Status message $i NO tag";
}

$c->bind('move', '<1>', sub {&mobileStart();});
$c->bind('move', '<B1-Motion>', sub {&mobileMove();});
$c->bind('move', '<ButtonRelease>', sub {&mobileStop();});

MainLoop;

sub checktag {
    if ( grep /TAF/, $c->gettags('current') ) {
        return 0;
    }
    else {
        return 1;
    }
}

sub mobileStart {
      my $ev = $c->XEvent;
      ($dx, $dy) = (0 - $ev->x, 0 - $ev->y);
      $c->raise('current');
      print "START MOVE->  $dx  $dy\n";
}

sub mobileMove {
      my $ev = $c->XEvent;
      
     #you can drag individuals or whole groups 
     # $c->move('current', $ev->x + $dx, $ev->y +$dy);
     
     if ( grep /TAF/, $c->gettags('current') ) {
       $c->move('current', $ev->x + $dx, $ev->y +$dy);
     }else{
       $c->move('group2', $ev->x + $dx, $ev->y +$dy);
     }
      
     ($dx, $dy) = (0 - $ev->x, 0 - $ev->y);
      print "MOVING->  $dx  $dy\n";
}

sub mobileStop{&mobileMove;}

[download]

and finally using tags to drag whole groups 

#!/usr/bin/perl
use warnings;
use strict;
use Tk;

my $dx;
my $dy;
my $grouptag; 

my $mw = MainWindow->new;
$mw->geometry("700x600");

my $x1 = 50;
my $x2 = 100;
my $y1 = 50;
my $y2 = 200;

my $c = $mw->Canvas(-width => 700, -height => 565,
                -bg => 'black',
           )->pack;

my $closebutton = $mw->Button(-text => 'Exit', -command => sub{Tk::exi
+t(0)})
               ->pack; 

my $parent = $c->createOval($x1, $y1, $x2, $y2, 
                             -fill => 'red',
                 -tags => ['mover','group1'],
                 );

my @children;
for (1..4) {
    push @children, $c->createLine(($x1 + $x2)/2,$y1, (2 * $x2), (2 * 
+$y2),
        #   -state =>'disabled', 
           -fill => 'white',
           -activefill  => 'green',
       -disabledfill => 'white',
       -tags => ['mover','group1','line','line'.$_],    
       );
        
    $x1 += 15; $x2 += 15;
         }

$c->bind('mover', '<1>', sub {&mobileStart();});
$c->bind('mover', '<B1-Motion>', sub {&mobileMove();});
$c->bind('mover', '<ButtonRelease>', sub {&mobileStop();});

MainLoop;

sub mobileStart {
      my $ev = $c->XEvent;
      ($dx, $dy) = (0 - $ev->x, 0 - $ev->y);
 
      my $curr_object = $c->find('withtag','current'); 
          print "curr->",@$curr_object,"\n";  #array dereference 
           my (@list) = $c->gettags($curr_object); 
           print "movelist->@list\n"; 

#         if( grep /line/, @list){ 
#             ($grouptag) = grep /(line\d+)/, @list; 
#     } else {($grouptag) = grep /(group\d+)/, @list; }
# JKrahn
#You are grep()ing through @list twice! and using capturing parenthese
+s!  Ick!            
#this is better
          unless ( ( $grouptag ) = grep /line\d/, @list ) {           
+                   
              ( $grouptag ) = grep /group\d/, @list;                  
+                   
              }                                                       
+                   
    #      print "grouptag-> $grouptag\n";
    #      print "START MOVE->  $dx  $dy\n";
}

sub mobileMove {
      my $ev = $c->XEvent;
      $c->move($grouptag, $ev->x + $dx, $ev->y +$dy);
      ($dx, $dy) = (0 - $ev->x, 0 - $ev->y);
     # print "MOVING->  $dx  $dy\n";
}

sub mobileStop{&mobileMove;}

[download]

And here is a draggable text on image example 

#!/usr/bin/perl
use warnings;
use strict;
use Tk;
use Tk::JPEG;
use Tk::PNG;

my $file = shift || die "need a bmp, gif,jpg or png as arg 1\n";

my ($dx,$dy);
my $mw  = Tk::MainWindow->new;

$mw->fontCreate('big',
   -family=>'arial',
   -weight=>'bold',
   -size=> 30);

my $can = $mw->Scrolled('Canvas',
                 -height => 400,
         -width  => 400,
         -scrollbars => 'osoe',
                 -highlightthickness=>0,
         -borderwidth =>0,
                 )->pack( -fill =>'both',-expand=>1);

my $realcan = $can->Subwidget('scrolled');

my $img = $mw->Photo( -file => $file );

$can->createImage(0,0,  #hardcoded offset
                  -image => $img, 
          -anchor => 'nw',
          -tags => ['img'],
           );

my @bbox = $can->bbox( 'img'  );

$can->configure(-scrollregion => [@bbox] );

my $text = 'This is some text';
$can->createText(50,50,
    -text   => $text,
    -fill =>'yellow',
    -anchor => 'nw',
    -font   => 'big',
    -tags=> ['move']
    );

$realcan->bind('move', '<1>', sub {&mobileStart();});
$realcan->bind('move', '<B1-Motion>', sub {&mobileMove();});
$realcan->bind('move', '<ButtonRelease>', sub {&mobileStop();});

MainLoop;

sub mobileStart {
      my $ev = $realcan->XEvent;
      ($dx, $dy) = (0 - $ev->x, 0 - $ev->y);
      $realcan->raise('current');
      print "START MOVE->  $dx  $dy\n";
}

sub mobileMove {
      my $ev = $realcan->XEvent;
      $realcan->move('current', $ev->x + $dx, $ev->y +$dy);
      ($dx, $dy) = (0 - $ev->x, 0 - $ev->y);
      print "MOVING->  $dx  $dy\n";
}

sub mobileStop{&mobileMove;}

[download]
I'm not really a human, but I play one on earth.
Old Perl Programmer Haiku ................... flash japh

In reply to Re: Simplest GUI with drag/drop/click on large image? by zentara
in thread Simplest GUI with drag/drop/click on large image? by halley

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":


  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?

www.com | www.net | www.org
Chatterbox?
and the web crawler heard nothing...

How do I use this? • Last hour • Other CB clients
Other Users?
Others contemplating the Monastery: (4)
As of 2024-04-20 02:44 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found