Beefy Boxes and Bandwidth Generously Provided by pair Networks
The stupid question is the question not asked

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


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


#!/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/
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.

Log In?

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

How do I use this? | Other CB clients
Other Users?
Others rifling through the Monastery: (12)
As of 2014-08-20 18:04 GMT
Find Nodes?
    Voting Booth?

    The best computer themed movie is:

    Results (121 votes), past polls