#!/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();
[download]

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;
[download]

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

Hello Christoph,

we would like to use this in our (Perl-licensed) application but would like to be sure that your code has the same license since you did not state anything above or your home node...

KR

lamprecht was last here 2 years ago

AFAIK, DynaMouseWheelBind comes from an old book ... there really isn't much to it, much less anything to license

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.

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.