home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2004 July / APC0407D2.iso / workshop / apache / files / ActivePerl-5.6.1.638-MSWin32-x86.msi / _35bdd1688b5a964e3b5bb98adbf7ff0d < prev    next >
Encoding:
Text File  |  2004-04-13  |  3.5 KB  |  104 lines
  1.  
  2.  
  3. sub scroll_enter {
  4.  
  5.     my($c) = @_;
  6.  
  7.     my $id = $c->find('withtag', 'current');
  8.     $id-- if ($c->gettags('current'))[0] eq 'text';
  9.     $mkScroll::old_fill = ($c->itemconfigure($id, -fill))[4];
  10.     if ($mkScroll->depth > 1) {
  11.     $c->itemconfigure($id, -fill => 'SeaGreen1');
  12.     } else {
  13.     $c->itemconfigure($id, -fill => 'black');
  14.     $c->itemconfigure($id+1, -fill => 'white');
  15.     }
  16.  
  17. } # end scroll_enter
  18.  
  19.  
  20. sub scroll_leave {
  21.  
  22.     my($c) = @_;
  23.  
  24.     my $id = $c->find('withtag', 'current');
  25.     $id-- if ($c->gettags('current'))[0] eq 'text';
  26.     $c->itemconfigure($id, -fill => $mkScroll::old_fill);
  27.     $c->itemconfigure($id+1, -fill => 'black');
  28.  
  29. } # end scroll_leave
  30.  
  31.  
  32. sub scroll_button {
  33.  
  34.     my($c) = @_;
  35.  
  36.     my $id = $c->find('withtag', 'current');
  37.     $id++ if ($c->gettags('current'))[0] ne 'text';
  38.     print STDOUT 'You buttoned at ', ($c->itemconfigure($id, -text))[4], "\n";
  39.  
  40. } # end scroll_button
  41.  
  42. sub mkScroll {
  43.  
  44.     # Create a top-level window containing a simple canvas that can be scrolled in two dimensions.
  45.  
  46.     $mkScroll->destroy if Exists($mkScroll);
  47.     $mkScroll = $top->Toplevel();
  48.     my $w = $mkScroll;
  49.     dpos $w;
  50.     $w->title('Scrollable Canvas Demonstration');
  51.     $w->iconname('Canvas');
  52.     $w->minsize(100, 100);
  53.  
  54.     my $w_msg = $w->Label(-font => '-Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-*', -wraplength => '4i',
  55.                -justify => 'left', -text => 'This window displays a canvas widget that can be scrolled either ' .
  56.                'using the scrollbars or by dragging with button 2 in the canvas.  If you click button 1 on one ' .
  57.                'of the rectangles, its indices will be printed on stdout.');
  58.     my $w_frame = $w->Frame();
  59.     my $w_ok = $w->Button(-text => 'OK', -width => 8, -command => ['destroy', $w]);
  60.     $w_msg->pack(-side => 'top', -fill => 'x');
  61.     $w_ok->pack(-side => 'bottom', -pady => '5');
  62.     $w_frame->pack(-side => 'top', -expand => 'yes', -fill => 'both');
  63.  
  64.     my $c = $w_frame->Canvas(-relief => 'sunken', -bd => 2, -scrollregion => ['-10c', '-10c', '50c', '20c']);
  65.     my $w_frame_vscroll = $w_frame->Scrollbar(-command => ['yview', $c]);
  66.     my $w_frame_hscroll = $w_frame->Scrollbar(-command => ['xview', $c], -orient => 'horiz');
  67.     $c->configure(-xscrollcommand => ['set', $w_frame_hscroll], -yscrollcommand => ['set', $w_frame_vscroll]);
  68.     $w_frame_vscroll->pack(-side => 'right', -fill => 'y');
  69.     $w_frame_hscroll->pack(-side => 'bottom', -fill => 'x');
  70.     $c->pack(-expand => 'yes', -fill => 'both');
  71.  
  72.     my($bg, $i, $j, $x, $y) = ($c->configure(-background))[4];
  73.     for ($i = 0; $i < 20; $i++) {
  74.     $x = -10 + 3 * $i;
  75.     $j = 0;
  76.     $y = -10;
  77.     while ($j < 10) {
  78.         $c->create('rectangle', sprintf("%dc", $x), sprintf("%dc", $y), sprintf("%dc", $x+2), sprintf("%dc", $y+2),
  79.                -outline => 'black', -fill => $bg, -tags => 'rect');
  80.         $c->create('text', sprintf("%dc", $x+1), sprintf("%dc", $y+1), -text => "$i,$j", -anchor => 'center',
  81.                -tags => 'text');
  82.         $j++;
  83.         $y += 3;
  84.     } # whilend
  85.     } # forend
  86.  
  87.     $c->bind('all', '<Any-Enter>' => sub {scroll_enter(@_)});
  88.     $c->bind('all', '<Any-Leave>' => sub {scroll_leave(@_)});
  89.     $c->bind('all', '<1>' => sub {scroll_button(@_)});
  90.     $c->Tk::bind('<2>' => sub {
  91.     my ($c) = @_;
  92.         my $e = $c->XEvent;
  93.     $c->scan('mark', $e->x, $e->y);
  94.     });
  95.     $c->Tk::bind('<B2-Motion>' => sub {
  96.     my ($c) = @_;
  97.         my $e = $c->XEvent;
  98.     $c->scan('dragto', $e->x, $e->y);
  99.     });
  100.  
  101. } # end MkScroll
  102.  
  103. 1;
  104.