Re: 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();
[download]

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

Comment on Re: Perl-Tk MouseWheel and Pane Select or Download Code

Replies are listed 'Best First'.
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	[reply]
Re^3: Perl-Tk MouseWheel and Pane by Anonymous Monk on Aug 05, 2009 at 10:51 UTC
Yes! Thank you! This saves a lot of work - as opposed to applying binding everywhere. :-) Jeff H.	[reply]
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	[reply]
Re^2: Perl-Tk MouseWheel and Pane by Anonymous Monk on Jan 22, 2016 at 10:22 UTC
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	[reply]
Re^3: Perl-Tk MouseWheel and Pane by Anonymous Monk on Jan 22, 2016 at 10:32 UTC
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	[reply]
Re^4: Perl-Tk MouseWheel and Pane by Anonymous Monk on Jan 22, 2016 at 10:39 UTC
I am aware of that and prodded him by mail. The lawyers I am concerned with won't agree with you... sadly. I have better things to do as well ;)	[reply]
Re^2: Perl-Tk MouseWheel and Pane by Anonymous Monk on Aug 05, 2009 at 10:59 UTC
Put this in CPAN! jeff h	[reply]
Re^3: Perl-Tk MouseWheel and Pane by Anonymous Monk on Feb 20, 2010 at 18:34 UTC
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.	[reply]
Re^4: Perl-Tk MouseWheel and Pane by Anonymous Monk on Apr 01, 2021 at 19:04 UTC
THANK YOU!!! 11 years later this comment has saved me from pulling out the few remaining hairs I have on my head. These comments should be preserved for as long as Perl exists in any form.	[reply]


Pathologically Eclectic Rubbish Lister
	PerlMonks