Beefy Boxes and Bandwidth Generously Provided by pair Networks
Keep It Simple, Stupid
 
PerlMonks  

Re: Perl-Tk MouseWheel and Pane

by lamprecht (Friar)
on May 20, 2009 at 12:49 UTC ( #765209=note: print w/ replies, xml ) Need Help??


in reply to Perl-Tk MouseWheel and Pane

Hi,

here is an example of a Mousewheel addon. It adds mousewheel bindings and directs mousewheel events to the 'innermost' widget belonging to a scrollable class based on the mousepointer location. This plays nicely with form-like composite widgets where some of the subwidgets are scrolled and others are not.

Cheers, Christoph

Usage:

#!/usr/bin/perl use Tk; use strict; use warnings; require Tk::DynaMouseWheelBind; my $mw = MainWindow->new(); $mw->geometry('300x300'); my @scrollables = ('Tk::Canvas', 'Tk::Text', 'Tk::Pane', 'Tk::Listbox', ); $mw->DynaMouseWheelBind(@scrollables); my $p = $mw->Scrolled('Pane')->pack(-expand => 1, -fill => 'both'); $p = $p->Subwidget('scrolled'); for (1..20){ $p->Entry->pack; } $p->Scrolled('Listbox')->pack->insert('end',(1..40)); MainLoop();

file Tk/DynaMouseWheelBind.pm:
require Tk::Widget; package Tk::Widget; use strict; use warnings; # keep Tk::Widgets namespace clean my($motion, $do_scroll, $mousewheel_event, $setup, ); sub DynaMouseWheelBind{ my $w = shift; my @classes = @_; my $mw = $w->MainWindow; $setup->($mw); for my $class (@classes) { eval "require $class" or die $@; # initialize class bindings so the following changes # won't get overridden $class->InitClass($mw); # replace MouseWheel bindings - these should be processed # through the $mw binding only my @mw_events = ('<MouseWheel>', '<4>', '<5>', ); $mw->bind($class,$_,'') for (@mw_events); $mw->bind($class,'<<DynaMouseWheel>>',$do_scroll); } } # setup two bindings to track the window under the cursor # and globally receive <MouseWheel> $setup = sub{ my $mw = shift; $mw->bind('all','<Motion>',$motion); # could be <Enter> as well $mw->bind('all','<MouseWheel>',[$mousewheel_event, Tk::Ev('D')]); $mw->bind('all','<4>',[$mousewheel_event, 120]); $mw->bind('all','<5>',[$mousewheel_event, -120]); }; { my $under_cursor ; my $scrollable; my $delta; $motion = sub { $under_cursor = $_[0]->XEvent->Info('W'); }; $do_scroll = sub{ $scrollable->yview('scroll', -($delta/120)*3, 'units'); }; $mousewheel_event = sub{ my $widget = shift; $delta = shift; # just in case, the mouse has not been moved yet: my $w = $under_cursor ||= $widget; my @tags = $w->bindtags; my $has_binding; until ($has_binding || $w->isa('Tk::Toplevel')){ if($w->Tk::bind(ref($w),'<<DynaMouseWheel>>')){ $has_binding = 1 ; }else{ $w = $w->parent; } } if ($has_binding) { $scrollable = $w; $w->eventGenerate('<<DynaMouseWheel>>'); } }; } # end of scope for $under_cursor, $scrollable, $delta 1;


Comment on Re: Perl-Tk MouseWheel and Pane
Select or Download Code
Re^2: Perl-Tk MouseWheel and Pane
by paxetbonum (Initiate) on May 20, 2009 at 14:46 UTC
    Thank you Lamprecht, Your nice code works perfectly. Lucio
      Yes! Thank you! This saves a lot of work - as opposed to applying binding everywhere. :-) Jeff H.
Re^2: Perl-Tk MouseWheel and Pane
by Anonymous Monk on Aug 05, 2009 at 10:59 UTC
    Put this in CPAN! jeff h
      just one note. When using Tk::Balloon with a mix of Frame and Pane, the "bind all Motion" should be changed to "bind all Enter". This corrected my issue with balloons for Buttons, etc. not showing up in a frame and a Scrolled Pane where I wanted to use the mouse wheel and have balloons.
Re^2: Perl-Tk MouseWheel and Pane
by Anonymous Monk on Nov 09, 2014 at 23:37 UTC
    Just a note from 5 years in the future: Wow, thank you Christoph, thank you Perl Monks, thank you Google! Yes, we are still struggling at making the mouse wheel scroll the scrolled(Pane) 5 years later

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others cooling their heels in the Monastery: (8)
As of 2015-07-04 14:22 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (60 votes), past polls