ppm3 install http://www.bribes.org/perl/ppm/Tk-TableMatrix.ppd

#!/usr/local/bin/perl -w

use Tk;
use Tk::TableMatrix;
require Tk::JBrowseEntry;
require Tk::DragDrop;
require Tk::DropSite;
use Tk::Font;

use strict;

my $top = MainWindow->new;
my $tm_array = {};

foreach my $row  (-1..6)
 {
  foreach my $col (-2..5)
   {
    $tm_array->{"$row,$col"} = "$row:$col";
   }
 }

sub row_sub
 {
  my $row = shift;
  return "OddRow" if( $row > 0 && $row % 2) 
 }

sub get_cell_coords
 {
  my $t = shift;
  my $table_x_offset = 50; # wegen linkem scrollbar, der ist 50px breit
  my $table_y_offset = 0;
  my $font = $t->cget(-font); 
  my ($x, $y, $pixel_x, $pixel_y) = (0, 0, 0, 0);

  # Tabellenbreite in Pixel bestimmen:
  for ($x=(-$t->cget('-titlecols')); $x<=($t->cget('-cols')); $x++)
   {
    $pixel_x += $font->measure("X" x ($t->colWidth($x))) + 1; # + 1 wegen 1px Rahmen
   }

  my $t_width = $pixel_x;                                                                     # Tabellenbreite
  my $t_height = ($font->actual('-size') + 1) * ($t->cget('-rows') + $t->cget('-titlerows')); # Tabellenhöhe
  my $x_offset = int(($t->xview)[0] * $t_width);  # Scroll-Offset X
  my $y_offset = int(($t->yview)[0] * $t_height); # Scroll-Offset Y
  my ($mouse_x, $mouse_y) = $t->pointerxy;   # Mausposition
  my $real_mouse_x = $mouse_x + $x_offset;   # echte Mausposition X (nach Scrollen)
  my $real_mouse_y = $mouse_y + $y_offset;   # echte Mausposition Y (nach Scrollen)
  my ($x_units, $y_units) = (0, 0);                             # Returnwert-Startwerte
  ($pixel_x, $pixel_y) = ($table_x_offset, $table_y_offset);    # Startwerte fürs iterieren, zwischen welchen Units die Mausposition liegt

  # X-Units bestimmen:
  for ($x=(-$t->cget('-titlecols')); $x<=($t->cget('-cols')); $x++)
   {
    my $current_col_width = $font->measure("x" x ($t->colWidth($x))) + 1; # + 1 wegen 1px Rahmen
    last if (($pixel_x + $current_col_width) > $real_mouse_x); # Wenn die nächste Iteration ausserhalb liegt, ist dies die richtige Zelle
    $pixel_x += $current_col_width;
    $x_units++;
   }

  # Y-Units bestimmen: 
  for ($y=(-$t->cget('-titlerows')); $y<=($t->cget('-rows')); $y++)
   {
    my $current_row_height = ($font->actual('-size') + 1) * $y; # + 1 wegen 1px Rahmen
    last if (($pixel_y + $current_row_height) > $real_mouse_y); # Wenn die nächste Iteration ausserhalb liegt, ist dies die richtige Zelle
    $pixel_y += $current_row_height;
    $y_units++;
   }

  return("$x_units:$y_units");
 }
 
my $label = $top->Label(-text => "Headline");

my $t = $top->Scrolled( 'TableMatrix', -rows => 8, -cols => 8, 
                        -width => 6, -height => 6,
                        -titlerows => 3, -titlecols => 2,
                        -variable => $tm_array,
                        -roworigin =>  -1,  -colorigin  => -2, 
                        -rowtagcommand => \&row_sub, 
                        -colstretchmode => 'last',
                        -rowstretchmode => 'last',
                        -selectmode => 'extended',
                        -sparsearray => 0 );

my $cb_use = $t->Checkbutton( -text => 'nutzen' ); 
my @test_arr = ( 'TEXT', 'ZAHL', '#.## ¤', '#.## ¤ / # ¤', 'PLZ', 'TT.MM.JJJJ', 'TT.MM.JJ' );
my $test_var = $test_arr[0];
my $be_format = $t->JBrowseEntry( -label => '', -variable => \$test_var, -choices => \@test_arr,
                                  -state => 'normal', -font => ['Tahoma', 8], -width => 10 );
my $lbl_hl = $t->Label( -text => 'Ãœberschrift', -font => ['Tahoma', 9],);

$t->windowConfigure("-1,0", -window=>$cb_use); 
$t->windowConfigure("0,0", -window=>$be_format); 
$t->windowConfigure("1,0", -window=>$lbl_hl); 

my $dnd_t = $t->DragDrop( -event => '<B1-Motion>', 
                          -sitetypes => [qw(Local)], 
                          -startcommand =>  sub { print "Dragged: ".(join(":", ($t->pointerxy))).
                                                        '   XScrollbar: '.(sprintf("%.2f", ($t->xview)[0]*100)).'%'.
                                                        '   YScrollbar: '.(sprintf("%.2f", ($t->yview)[0]*100)).'%'.
                                                        '   Widget Position: '.&get_cell_coords($t)."\n"; return 0; } );
my $ds_t = $t->DropSite ( -droptypes     => ['Local'], 
                          -dropcommand   => sub { print "Dropped ".(join(":", ($t->pointerxy))).
                                                        '   XScrollbar: '.(sprintf("%.2f", ($t->xview)[0]*100)).'%'.
                                                        '   YScrollbar: '.(sprintf("%.2f", ($t->yview)[0]*100)).'%'.
                                                        '   Widget Position: '.&get_cell_coords($t)."\n"; } );

my $button = $top->Button( -text => "Exit", -command => sub{ $top->destroy } );      

$t->tagConfigure('OddRow', -bg => '#999999', -fg => 'black');
$t->colWidth( -2 => 7, -1 => 7, 1=> 5, 2 => 8, 4=> 14);

$label->pack( -expand => 1, -fill => 'both');
$t->pack(-expand => 1, -fill => 'both');
$button->pack(-expand => 1, -fill => 'both');

Tk::MainLoop;

$VAR1 = bless( do{\(my $o = '&‼           ¼P&┘&☺$$Þ&☺$$Þ&☺    p&♣Æ|    m&♣Æ|ÃŒ&┬&┐w  "
 Ã’&┬&┐w0B" &â•š#Ã’&☺   &┤ØÓ&☺{        ²@&☺Gµ7 l¯&â–„&☺        X&â™ &┘&☺l¯&â–„&☺¼*&â–„&☺')}, 'XEvent' );

my $ds_t = $t->DropSite ( -droptypes     => ['Local'], 
                          -dropcommand   => sub { print "Dropped Main: ".(join(":", ($t->pointerxy))).' Table: '.(join(":", ($top->pointerxy))).
                                                        '   XScrollbar: '.(sprintf("%.2f", ($t->xview)[0]*100)).'%'.
                                                        '   YScrollbar: '.(sprintf("%.2f", ($t->yview)[0]*100)).'%'.
                                                        '   Widget Position: '.&get_cell_coords($t).'   XEvent: '.($t->XEvent->X).':'.($t->XEvent->Y).' Index: '.($t->index( '@'.(($t->pointerxy)[0]).','.(($t->pointerxy)[1]) )).' '."\n"; } );