Beefy Boxes and Bandwidth Generously Provided by pair Networks
No such thing as a small change
 
PerlMonks  

Re: Simplest GUI with drag/drop/click on large image?

by zentara (Archbishop)
on Sep 07, 2011 at 16:28 UTC ( [id://924621]=note: print w/replies, xml ) Need Help??


in reply to Simplest GUI with drag/drop/click on large image?

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 }

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;}

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;}

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;}

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

Replies are listed 'Best First'.
Re^2: Simplest GUI with drag/drop/click on large image?
by halley (Prior) on Sep 07, 2011 at 17:08 UTC

    I could kiss ya. These demos are exactly what I needed.

    I almost cringed at the inclusion of the .xpm data, but then found it supported more mainstream formats too. Even alpha transparency in PNGs.

    --
    [ e d @ h a l l e y . c c ]

Log In?
Username:
Password:

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

How do I use this?Last hourOther CB clients
Other Users?
Others exploiting the Monastery: (4)
As of 2024-03-29 00:25 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found