FAQ Perl/TkConsultez toutes les FAQ

Nombre d'auteurs : 3, nombre de questions : 86, dernière mise à jour : 24 mai 2013  Ajouter une question

 

Bienvenue sur la FAQ Perl/Tk. Cette FAQ a pour vocation de vous enseigner ou de vous faire revoir les notions de Perl/Tk. N'hésitez pas à utiliser le moteur de recherche.

Vous souhaitez participer à l'amélioration de cette FAQ, n'hésitez pas !! Commentez

Bonne lecture !


SommaireTous les widgetsLes tableaux (3)
précédent sommaire suivant
 

Pour créer des tableaux (c'est-à-dire des grilles ou classeurs) en Perl/Tk, il est possible de le faire soi-même en utilisant le gestionnaire d'espace grid, mais c'est assez (voire très) compliqué en fonction de ses besoins. Néanmoins, le CPAN comme d'habitude, nous offre déjà des modules nous facilitant la vie.


Ce module est simple d'utilisation et déjà présent dans le core de Tk, donc pas besoin de l'installer si Tk l'est. Dans chaque cellule, on peut mettre un widget de notre choix. Son inconvénient est qu'il est très très consommateur de mémoire et pour de gros tableaux, il n'est pas adapté. De plus, il est impossible de redimensionner la largeur des colonnes via la souris. Mais n'hésitez tout de même pas à l'utiliser pour de simples tableaux.




Il est simple pour la génération de tableaux avec des cellules de type texte. Il permet d'y mettre un entête et en plus, nous avons la possibilité de gérer le tri via un clic sur l'entête. La grille peut également être éditable. Son utilisation nécessite son installation.




Ce module est déjà plus intéressant (pour les cellules de type texte) car en plus de l'entête, il permet de redimensionner automatiquement les colonnes et de paramétrer le tri via un clic sur le bouton d'une colonne d'entête. Sa mise en place n'est tout de même pas évidente et son utilisation nécessite son installation.




Ce module bien que nécessitant son installation, est le plus intéressant, efficace, complet et performant. Ecrit en C, ce module est très rapide même pour des tableaux volumineux. De plus, il est vraiment complet et configurable à souhait. Dans chaque cellule, on peut mettre du texte ou des widgets. Les tris et la fusion de cellules sont également possibles. Le redimensionnement des colonnes et des lignes, ainsi que la création d'entête sur une ou plusieurs lignes ou colonnes sont faisables. On peut créer un vrai classeur éditable.

Ce module contient un répertoire démo dans lequel il y a des programmes d'exemples. Voici un code illustrant ce que l'on peut faire.

Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
#!/usr/bin/perl 
use warnings; 
use strict; 
  
use Tk; 
use Tk::TableMatrix; 
use utf8; 
  
my $mw = MainWindow->new( 
  -title      => 'Tableau TableMatrix', 
  -background => 'snow', 
); 
$mw->Label( 
  -text       => "Tableau redimensionnable à l'aide de TableMatrix", 
  -background => 'snow', 
  -font       => '{arial} 12 bold' 
)->pack( -pady => 5 ); 
  
my $data = {}; 
  
# Création du tableau avec une ligne et une colonne 
my $table = $mw->Scrolled( 
  'TableMatrix', 
  -rows          => 1, 
  -cols          => 1, 
  -width         => 500, 
  -height        => 500, 
  -variable      => $data, 
  -rowtagcommand => \&type_row, 
  -background    => "#454545", 
  -titlerows     => 1, 
  -titlecols     => 1, 
  -drawmode      => 'single', 
  -selectmode    => 'extended', 
  -scrollbars    => 'osoe', 
); 
  
# Insertion de données dans le tableau 
for my $row ( 0 .. 20 ) { 
  
  # Calcul du nombre de lignes dans le tableau 
  my $number_rows = $table->cget( -rows ); 
  
  # Insertion d'une ligne si nécessaire 
  $table->insertRows( 'end', 1 ) if ( $number_rows < $row + 1 ); 
  
  for my $col ( 0 .. 10 ) { 
  
    # Calcul du nombre de lignes dans le tableau 
    my $number_cols = $table->cget( -cols ); 
  
    # Insertion d'une colonne si nécessaire 
    $table->insertCols( 'end', 1 ) if ( $number_cols < $col + 1 ); 
  
    # Ligne de titre 
    if ( $row == 0 and $col != 0 ) { 
      $data->{"$row,$col"} = "Colonne $col"; 
    } 
  
    # Colonne de titre 
    elsif ( $col == 0 and $row != 0 ) { 
      $data->{"$row,$col"} = "Ligne $row"; 
    } 
    elsif ( $col == 0 and $row == 0 ) { 
  
      # rien ne se passe; 
    } 
  
    # Données 
    else { 
      $data->{"$row,$col"} = "($row,$col)"; 
    } 
  } 
} 
  
# Configuration des lignes paires et impaires 
$table->tagConfigure( 
  'pair_row', 
  -bg     => 'white', 
  -fg     => 'black', 
  -relief => 'sunken', 
  -state  => 'disabled' 
); 
$table->tagConfigure( 
  'impair_row', 
  -bg     => '#00C0E0', 
  -fg     => 'black', 
  -relief => 'sunken', 
  -state  => 'disabled' 
); 
$table->tagConfigure( 'title', -bg => '#F0E0FF', -fg => 'black', -relief => 'sunken' ); 
# Fusion des cellules 1,1 à 1,4 
$table->spans( '1,1' => '0,3' ); 
$table->pack(qw/ -fill both -expand 1 -padx 10 -pady 10 /); 
  
MainLoop; 
  
# Permet d'assigner un tag aux lignes paires et impaires 
sub type_row { 
  my $row = shift; 
  my $tag_row = ( $row > 0 && $row % 2 == 0 ) ? "pair_row" : "impair_row"; 
  
  return $tag_row; 
}
Voici le résultat :

Je vous conseille de lire attentivement la documentation de ce module car elle est abondante. Mais l'utilisation du module est simple. Soyez donc patient !!

Mis à jour le 1er novembre 2010 djibril

Voici deux programmes issus de la documentation du module :

Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
#!/usr/bin/perl -w 
  
## THIS IS ONE OF THE TEST SCRIPTS THAT HANS PROVIDED WITH MLISTBOX 
## It IS STILL UNDERGOING EDITS BY ME - RCS 
  
## MListbox demonstration application. This is a simple directory browser 
## Original Author: Hans J. Helgesen, December 1999. 
## Modified by: Rob Seegel, to work in Win32 as well 
## Use and abuse this code. I did - RCS 
  
use File::stat; 
use Tk; 
use Tk::MListbox; 
  
## Create main perl/tk window. 
my $mw = MainWindow->new; 
  
## Create the MListbox widget. 
## Specify alternative comparison routine for integers and date. 
## frame, but since the "Show All" button references $ml, we have to create 
## it now. 
  
my %red   = qw(-bg red -fg white); 
my %green = qw(-bg green -fg white); 
my %white = qw(-fg black); 
  
my $ml = $mw->Scrolled( 
  'MListbox', 
  -scrollbars         => 'osoe', 
  -background         => 'white', 
  -foreground         => 'blue', 
  -textwidth          => 10, 
  -highlightthickness => 2, 
  -width              => 0, 
  -selectmode         => 'browse', 
  -bd                 => 2, 
  -relief             => 'sunken', 
  -columns            => [ 
    [ qw/-text Mode -textwidth 10/, %red ], 
    [ qw/-text NLink -textwidth 5/, %green, -comparecmd => sub { $_[0] <=> $_[1] } ], 
    [ qw/-text UID/,                %white ], 
    [ qw/-text GID/,                %green ], 
    [ qw/-text Size/,               %red,   -comparecmd => sub { $_[0] <=> $_[1] } ], 
    [ qw/-text Mtime/, %green, -comparecmd => \&compareDate ], 
    [ qw/-text Name/,  %white ] 
  ] 
); 
  
## Put the exit button and the "Show All" button in 
## a separate frame. 
my $f = $mw->Frame( 
  -bd     => 2, 
  -relief => 'groove' 
)->pack(qw/-anchor w -expand 0 -fill x/); 
  
$f->Button( 
  -text    => 'Exit', 
  -command => sub {exit} 
)->pack(qw/-side right -anchor e/); 
  
$f->Button( 
  -text    => 'Show All', 
  -command => sub { 
    foreach ( $ml->columnGet( 0, 'end' ) ) { 
      $ml->columnShow($_); 
    } 
  } 
)->pack(qw/-side left -anchor w/); 
  
# Put the MListbox widget on the bottom of the main window. 
$ml->pack( -expand => 1, -fill => 'both', -anchor => 'w' ); 
  
# Double clicking any of the data rows calls openFileOrDir() 
# (But only directories are handled for now...) 
$ml->bindRows( "<Double-Button-1>", \&openFileOrDir ); 
  
# Right-clicking the column heading creates the hide/show popup menu. 
$ml->bindColumns( "<Button-3>", [ \&columnPopup ] ); 
  
$ml->bindRows( 
  '<ButtonRelease-1>', 
  sub { 
    my ( $w, $infoHR ) = @_; 
    print "You selected row: " . $infoHR->{-row} . " in column: " . $infoHR->{-column} . "\n"; 
  } 
); 
  
# Start by showing the current directory. 
directory("."); 
  
MainLoop; 
  
#---------------------------------------------------------- 
# 
sub directory { 
  my ($dir) = @_; 
  
  chdir($dir); 
  
  my $pwd = `pwd`; 
  chomp $pwd; 
  $mw->title("Directory: $pwd"); 
  
  # Empty $ml 
  $ml->delete( 0, 'end' ); 
  
  opendir( DIR, "." ) or die "Cannot open '.': $!\n"; 
  
  foreach my $name ( readdir(DIR) ) { 
    my $st   = stat($name); 
    my $mode = $st->mode; 
  
    my $type = do { 
      if ( -l $name ) { 
        $mode = 0777; 
        'l'; 
      } 
      elsif ( -f $name ) { 
        '-'; 
      } 
      elsif ( -d $name ) { 
        'd'; 
      } 
      elsif ( -p $name ) { 
        'p'; 
      } 
      elsif ( -b $name ) { 
        'b'; 
      } 
      elsif ( -c $name ) { 
        'c'; 
      } 
      else { 
        ' '; 
      } 
    }; 
  
    my $mtime = localtime( $st->mtime ); 
    $mode = $type . convMode( $st->mode ); 
    $ml->insert( 'end', [ $mode, $st->nlink, $st->uid, $st->gid, $st->size, $mtime, $name ] ); 
  } 
} 
  
# This callback is called if the user double-clicks one of the rows in 
# the MListbox. If the selected file is a directory, open it. 
# 
sub openFileOrDir { 
  my @sel = $ml->curselection; 
  if ( @sel == 1 ) { 
    my ( $mode, $name ) = ( $ml->getRow( $sel[0] ) )[ 0, 6 ]; 
    if ( $mode =~ m/^d/ ) {    # Directory? 
      directory($name); 
    } 
  } 
} 
  
# This callback is called if the user right-clicks the column heading. 
# Create a popupmenu with hide/show options. 
sub columnPopup { 
  my ( $w, $infoHR ) = @_; 
  
  # Create popup menu. 
  my $menu = $w->Menu( -tearoff => 0 ); 
  my $index = $infoHR->{'-column'}; 
  
  # First item is "Hide (this column)". 
  # 
  $menu->add( 
    'command', 
    -label   => "Hide " . $w->columnGet($index)->cget( -text ), 
    -command => sub { 
      $w->columnHide($index); 
    } 
  ); 
  $menu->add('separator'); 
  
  # Create a "Show" entry for each column that is not currently visible. 
  # 
  foreach ( $w->columnGet( 0, 'end' ) ) {    # Get all columns from $w. 
    unless ( $_->ismapped ) { 
      $menu->add( 
        'command', 
        -label   => "Show " . $_->cget( -text ), 
        -command => [ $w => 'columnShow', $_, -before => $index ], 
      ); 
    } 
  } 
  $menu->Popup( -popover => 'cursor' ); 
} 
  
# Converts a numeric file mode to the format provided by the ls command. 
# 
sub convMode { 
  my $mode   = shift; 
  my $result = ''; 
  
  $result .= ( $mode & 0400 ) ? 'r' : '-'; 
  $result .= ( $mode & 0200 ) ? 'w' : '-'; 
  if ( $mode & 0100 ) { 
    if ( $mode & 04000 ) { 
      $result .= 's'; 
    } 
    else { 
      $result .= 'x'; 
    } 
  } 
  else { 
    $result .= '-'; 
  } 
  
  $result .= ( $mode & 040 ) ? 'r' : '-'; 
  $result .= ( $mode & 020 ) ? 'w' : '-'; 
  if ( $mode & 010 ) { 
    if ( $mode & 02000 ) { 
      if ( ( $mode & 02010 ) 
        || ( $mode & 02030 ) 
        || ( $mode & 02050 ) 
        || ( $mode & 02070 ) ) 
      { 
        $result .= 's'; 
      } 
      else { 
        $result .= 'l'; 
      } 
    } 
    else { 
      $result .= 'x'; 
    } 
  } 
  else { 
    $result .= '-'; 
  } 
  
  $result .= ( $mode & 04 ) ? 'r' : '-'; 
  $result .= ( $mode & 02 ) ? 'w' : '-'; 
  $result .= ( $mode & 01 ) ? 'x' : '-'; 
  
  return $result; 
} 
  
# Callback for date comparison. Expects that the dates are on the format 
# "day mon dd hh:mm:ss yyyy", for example "Tue Dec  7 12:13:11 1999". 
# 
sub compareDate { 
  my ( $d1, $d2 ) = @_; 
  convertDate($d1) cmp convertDate($d2); 
} 
  
sub convertDate { 
  my ($str) = @_; 
  my ( $wday, $mon, $day, $hour, $min, $sec, $year ) 
    = ( $str =~ m/(\S*)\s*(\S*)\s*(\d*)\s*(\d\d):(\d\d):(\d\d)\s*(\d\d\d\d)/ ); 
  
  my $month = 0; 
  foreach (qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/) { 
    if ( $mon eq $_ ) { 
      last; 
    } 
    else { 
      $month++; 
    } 
  } 
  return sprintf( "%04d%02d%02d%02d%02d%02d", $year, $month, $day, $hour, $min, $sec ); 
}
Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
#!/usr/bin/perl -w 
  
# MListbox demonstration application. 
  
# Author: Hans J. Helgesen, December 1999. 
# 
# Before March 2000: 
# 
# Please send comments, suggestions and error reports to 
# hans_helgesen@hotmail.com. 
# 
# From March 2000: hans.helgesen@novit.no 
# 
use Tk; 
use Tk::MListbox; 
use Tk::Pane; 
use DBI; 
  
my $intro = <<EOT; 
This is a very simple DBI application that demonstrates the use of MListbox $Tk::MListbox::VERSION. 
  
* To execute a query, type the query in the query window and click "GO". 
* To resize any of the columns, drag the vertical bar to the RIGHT of the column. 
* To move any of the columns, drag the column header left or right. 
* To sort the table, click on any of the column headers. A new click will reverse the sort order. 
  
Note that this program calls MListbox->insert, MListbox->see and MListbox->update once FOR EACH ROW  
fetched from the database. This is not very efficient, a better approach would be to store all rows  
in an array, and then call MListbox->insert once when the query is done. 
  
EOT 
  
my $status = 'Idle'; 
  
# Check argument. 
if ( @ARGV != 3 ) { 
  print STDERR "Usage: $0 source userid password\n"; 
  print STDERR "Example: $0 dbi:Oracle:oradb peter secretpwd\n"; 
  exit 1; 
} 
  
# Connect to the database. 
my $dbh = DBI->connect(@ARGV) or die "Can't connect: $DBI::errstr\n"; 
  
# Create Tk window... 
my $mw = new MainWindow; 
$mw->title("SQL $ARGV[1]\@$ARGV[0]"); 
  
$mw->Label( -text => $intro, -justify => 'left' )->pack( -anchor => 'w' ); 
  
my $f = $mw->Frame->pack( -fill => 'x', -anchor => 'w' ); 
my $text = $f->Scrolled( 
  'Text', 
  -scrollbars => 'osoe', 
  -width      => 80, 
  -height     => 5 
  )->pack( 
  -side   => 'left', 
  -expand => 1, 
  -fill   => 'both' 
  ); 
  
$text->insert( 'end', "select * from all_objects where object_type='TABLE'" ); 
$f = $f->Frame->pack( -side => 'left' ); 
  
$f->Button( 
  -text    => 'Go', 
  -command => sub { 
    $mw->Busy( -recurse => 1 ); 
    execSQL(); 
    $mw->Unbusy; 
  } 
)->pack; 
  
$f->Button( 
  -text    => 'Clear', 
  -command => sub { 
    $text->delete( '0.0', 'end' ); 
  } 
)->pack; 
  
$f->Button( 
  -text    => 'Exit', 
  -command => sub { 
    $dbh->disconnect; 
    exit; 
  } 
)->pack; 
  
# Put the MListbox in a Pane, since the MListbox don't support horizontal 
# scrolling by itself. 
# 
$f = $mw->Frame->pack( -fill => 'x' ); 
$f->Label( -text => 'Status:' )->pack( -side => 'left' ); 
$f->Label( -textvariable => \$status )->pack( -side => 'left' ); 
  
my $ml = $mw->Scrolled( 'MListbox', -scrollbars => 'osoe' )->pack( -expand => 1, -fill => 'both' ); 
  
MainLoop; 
  
#-------------------------------------------------------------------- 
# 
sub execSQL { 
  
  # Get the query from the text widget. 
  my $sql = $text->get( '0.0', 'end' ); 
  
  $status = 'Call prepare()'; 
  $mw->update; 
  
  my $sth = $dbh->prepare($sql); 
  unless ( defined $sth ) { 
    $text->insert( 'end', "\nprepare() failed: $DBI::errstr\n" ); 
    return; 
  } 
  $status = 'Call execute()'; 
  $mw->update; 
  unless ( $sth->execute ) { 
    $text->insert( 'end', "\nexecute() failed: $DBI::errstr\n" ); 
    return; 
  } 
  
  # Query OK, delete all old columns in $ml. 
  # 
  $ml->columnDelete( 0, 'end' ); 
  my $headings_defined = 0; 
  $status = 'Call fetchrow()'; 
  $mw->update; 
  my $rowcnt = 0; 
  
  while ( my $hashref = $sth->fetchrow_hashref ) { 
    unless ($headings_defined) { 
      foreach ( sort keys %$hashref ) { 
        $ml->columnInsert( 'end', -text => $_ ); 
      } 
      $headings_defined = 1; 
    } 
    my @row = (); 
    foreach ( sort keys %$hashref ) { 
      push @row, $hashref->{$_}; 
    } 
    $ml->insert( 'end', [@row] ); 
    $ml->see('end'); 
    $rowcnt++; 
    $status = "$rowcnt rows fetched"; 
    $ml->update; 
  } 
  $status = 'Idle'; 
}

Mis à jour le 14 avril 2011 djibril

Etant donné qu'il n'est pas toujours évident de trouver les exemples fournis dans les modules du CPAN, je vous propose quelques programmes provenant de Tk::TableMatrix.

Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
#!/usr/bin/perl 
use warnings; 
use strict; 
use Tk; 
use Tk::TableMatrix; 
  
my $top = MainWindow->new; 
  
my $arrayVar = {}; 
for my $r ( 0 .. 7 ) { 
  for my $c ( 0 .. 7 ) { 
    $arrayVar->{"$r,$c"} = 'test'; 
  } 
} 
  
my $t = $top->Scrolled( 
  'TableMatrix', 
  -variable   => $arrayVar, 
  -selectmode => 'extended', 
  -bg         => 'white', 
  -fg         => 'black', 
); 
  
$t->configure( 
  -browsecmd => sub { 
    my ( $previous_index, $current_index ) = @_; 
  
    if ( $previous_index =~ m{^\d+,\d+$} ) { 
      my $value_previous_cell = $t->get($previous_index); 
  
      # check and validation 
      if ( $value_previous_cell =~ s{^(\d+)/(\d+)$}{$1/$2/2010} ) { 
        $t->activate($previous_index); 
        $t->curvalue($value_previous_cell); 
        $t->activate($current_index); 
      } 
  
    } 
  }, 
); 
  
$t->pack( -expand => 1, -fill => 'both' ); 
  
MainLoop;
Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
## buttons.tcl 
## 
## demonstrates the simulation of a button array 
## 
## ellson@lucent.com 
## modifications made by jeff.hobbs@acm.org 
##  Mdofied by John Cerney for perl/tk 
  
use Tk; 
  
use Tk::TableMatrix; 
  
use Data::Dumper qw( DumperX); 
my $top = MainWindow->new; 
  
my $tab = {}; 
my ( $rows, $cols ) = ( 10, 10 );    # number of rows/cols 
  
# create the table 
my $t = $top->Scrolled( 
  'TableMatrix', 
  -rows        => $rows, 
  -cols        => $cols, 
  -titlerows   => 1, 
  -titlecols   => 1, 
  -roworigin   => -1, 
  -colorigin   => -1, 
  -colwidth    => 4, 
  -width       => 8, 
  -height      => 8, 
  -variable    => $tab, 
  -flashmode   => 'off', 
  -cursor      => 'top_left_arrow', 
  -borderwidth => 2, 
  -state       => 'disabled' 
); 
$t->pack; 
  
# set up tags for the various states of the buttons 
$t->tagConfigure( 'OFF', -bg => 'red',    -relief => 'raised' ); 
$t->tagConfigure( 'ON',  -bg => 'green',  -relief => 'sunken' ); 
$t->tagConfigure( 'sel', -bg => 'gray75', -relief => 'flat' ); 
  
# clean up if mouse leaves the widget 
$t->bind( 
  '<FocusOut>', 
  sub { 
    my $w = shift; 
    $w->selectionClear('all'); 
  } 
); 
  
# highlight the cell under the mouse 
$t->bind( 
  '<Motion>', 
  sub { 
    my $w  = shift; 
    my $Ev = $w->XEvent; 
    if ( $w->selectionIncludes( '@' . $Ev->x . "," . $Ev->y ) ) { 
      Tk->break; 
    } 
    $w->selectionClear('all'); 
    $w->selectionSet( '@' . $Ev->x . "," . $Ev->y ); 
    Tk->break; 
    ## "break" prevents the call to TableMatrixCheckBorder 
  } 
); 
  
# mousebutton 1 toggles the value of the cell 
# use of "selection includes" would work here 
$t->bind( 
  '<1>', 
  sub { 
    my $w = shift; 
    $w->focus; 
    my $dude = $w->curselection; 
    my ($rc) = @{ $w->curselection }; 
    my $var  = $w->cget( -var ); 
    if ( $var->{$rc} =~ /ON/ ) { 
      $var->{$rc} = 'OFF'; 
      $w->tagCell( 'OFF', $rc ); 
    } 
    else { 
      $var->{$rc} = 'ON'; 
      $w->tagCell( 'ON', $rc ); 
    } 
  } 
); 
  
# inititialize the array, titles, and celltags 
for ( $i = 0; $i < $rows; $i++ ) { 
  $tab->{"$i,-1"} = $i; 
  for ( $j = 0; $j < $cols; $j++ ) { 
    unless ($i) { $tab->{"-1,$j"} = $j; } 
    $tab->{"$i,$j"} = "OFF"; 
    $t->tagCell( 'OFF', "$i,$j" ); 
  } 
} 
  
Tk::MainLoop;
Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
## command.tcl 
## 
## This demo shows the use of the table widget's -command options 
## 
## jeff.hobbs@acm.org 
##  Converted to perl/tk by John Cerney 
  
use Tk; 
  
use Tk::TableMatrix; 
  
my ( $rows, $cols ) = ( 10, 10 );    # number of rows/cols 
my $top = MainWindow->new; 
  
# Sub to fill the array variable 
sub fill { 
  
  my ( $array, $x, $y ) = @_; 
  my ( $i, $j ); 
  for ( $i = -$x; $i < $x; $i++ ) { 
    for ( $j = -$y; $j < $y; $j++ ) { 
      $array->{"$i,$j"} = "$i x $j"; 
    } 
  } 
} 
  
## Test out the use of a callback to define tags on rows and columns 
sub rowSub { 
  my $row = shift; 
  return "OddRow" if ( $row > 0 && $row % 2 ); 
} 
  
sub colSub { 
  my $col = shift; 
  return "OddCol" if ( $col > 0 && $col % 2 ); 
} 
  
sub tblCmd { 
  my ( $array, $set, $row, $col, $val ) = @_; 
  
  # my @args = @_; 
  # print "In Table Command, Args = '".join("', '",@args)."'\n"; 
  
  my $index = "$row,$col"; 
  if ($set) { 
    $array->{$index} = $val; 
  } 
  else { 
    if ( defined( $array->{$index} ) ) { 
      return $array->{$index}; 
    } 
    else { 
      return ''; 
    } 
  } 
} 
  
my $label = $top->Label( -text => "TableMatrix -command Example" ); 
  
# Label the changes with the value of currentTest 
my $currentText = ''; 
my $currentLabel = $top->Label( -textvariable => \$currentText ); 
  
# Entry that changes with the value of activeText 
my $activeText = ''; 
my $activeEntry = $top->Entry( -textvariable => \$activeText ); 
  
my $arrayVar = {}; 
  
fill( $arrayVar, $rows, $cols );    # fill up the array variable 
  
my $t = $top->Scrolled( 
  'TableMatrix', 
  -rows          => $rows, 
  -cols          => $cols, 
  -width         => 6, 
  -height        => 6, 
  -titlerows     => 1, 
  -titlecols     => 2, 
  -command       => [ \&tblCmd, $arrayVar ], 
  -roworigin     => -1, 
  -colorigin     => -2, 
  -rowtagcommand => \&rowSub, 
  -coltagcommand => \&colSub, 
  -selectmode    => 'extended', 
  -flashmode     => 'on', 
  -variable      => $arrayVar, 
  
); 
  
$t->configure( 
  -browsecommand => sub { 
    my ($index) = @_; 
    $currentText = $index; 
    $activeText  = $t->get($index); 
  } 
); 
  
$t->configure( 
  -validate        => 1, 
  -validatecommand => sub { 
    my ( $row, $col, $old, $new, $index ) = @_; 
    $activeText = $new; 
    return 1; 
  } 
); 
$t->configure( 
  -selectioncommand => sub { 
    my ( $NumRows, $Numcols, $selection, $noCells ) = @_; 
    my @args = @_; 
    print "In Selection Command, Args = '" . join( "', '", @args ) . "'\n"; 
    return $selection; 
  } 
); 
  
# hideous Color definitions here: 
$t->tagConfigure( 'OddRow', -bg => 'orange', -fg => 'purple' ); 
$t->tagConfigure( 'OddCol', -bg => 'brown',  -fg => 'pink' ); 
  
$t->colWidth( -2 => 7, -1 => 7, 1 => 5, 2 => 8, 4 => 14 ); 
  
$label->pack( -expand => 1, -fill => 'both' ); 
$currentLabel->pack( -expand => 1, -fill => 'both' ); 
$activeEntry->pack( -expand => 1, -fill => 'both' ); 
  
$t->pack( -expand => 1, -fill => 'both' ); 
  
Tk::MainLoop;
Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
## version2.tcl 
## 
## This demo uses most features of the table widget 
## 
## jeff.hobbs@acm.org 
##  Converted to perl/tk by John Cerney 
  
use Tk; 
  
use Tk::TableMatrix; 
  
my ( $rows, $cols ) = ( 25, 20 );    # number of rows/cols 
my $top = MainWindow->new; 
  
# Sub to fill the array variable 
sub fill { 
  
  my ( $array, $x, $y ) = @_; 
  my ( $i, $j ); 
  for ( $i = -$x; $i < $x; $i++ ) { 
    for ( $j = -$y; $j < $y; $j++ ) { 
      $array->{"$i,$j"} = "r$i,c$j"; 
    } 
  } 
} 
  
## Test out the use of a callback to define tags on rows and columns 
sub colSub { 
  my $col = shift; 
  return "OddCol" if ( $col > 0 && $col % 2 ); 
} 
  
my $label = $top->Label( -text => "TableMatrix v2 Example" ); 
  
my $arrayVar = {}; 
  
fill( $arrayVar, $rows, $cols );    # fill up the array variable 
  
my $t = $top->Scrolled( 
  'TableMatrix', 
  -rows          => $rows, 
  -cols          => $cols, 
  -variable      => $arrayVar, 
  -width         => 6, 
  -height        => 8, 
  -titlerows     => 1, 
  -titlecols     => 2, 
  -roworigin     => -5, 
  -colorigin     => -2, 
  -coltagcommand => \&colSub, 
  -selectmode    => 'extended', 
  -selecttitles  => 0, 
  -drawmode      => 'single', 
  
); 
  
my $button = $top->Button( -text => "Exit", -command => sub { $top->destroy } ); 
$label->pack( -expand => 1, -fill => 'both' ); 
  
$t->pack( -expand => 1, -fill => 'both' ); 
$button->pack( -expand => 1, -fill => 'both' ); 
  
# hideous Color definitions here: 
$t->tagConfigure( 'OddCol', -bg => 'brown', -fg => 'pink' ); 
$t->tagConfigure( 'title', -bg => 'red', -fg => 'blue', -relief => 'sunken' ); 
$t->tagConfigure( 'dis', -state => 'disabled' ); 
  
my $i     = -1; 
my $first = $t->cget( -colorigin ); 
my $anchor; 
foreach $anchor (qw/ n s e w nw ne sw se c /) { 
  $t->tagConfigure( $anchor, -anchor => $anchor ); 
  $t->tagRow( $anchor, ++$i ); 
  $t->set( "$i,$first", $anchor ); 
} 
$top->fontCreate( 'courier', -family => 'courier', -size => 10 ); 
$t->tagConfigure( 's', -font => 'courier', -justify => 'center' ); 
  
# $initWindow->Label(-image => $top->Photo(-file => Tk->findINC('Xcamel.gif')))->pack; 
  
my $perltkLogo = $top->Photo( -file => Tk->findINC('Xcamel.gif') ); 
  
$t->tagConfigure( 'logo', -image => $perltkLogo, -showtext => 1 ); 
$t->tagCell( 'logo', '1,2', '2,3',  '4,1' ); 
$t->tagCell( 'dis',  '2,1', '1,-1', '3,0' ); 
$t->colWidth(qw/ -2 8 -1 9 0 12 4 14/); 
  
$t->set( 
  '1,1' => "multi-line\ntext\nmight be\ninteresting", 
  '3,2' => "more\nmulti-line\nplaying\n", 
  '2,2' => "null\0byte" 
); 
  
$i = -1; 
  
# This is in the row span 
my $l = $top->Label( -text => "Window s", -bg => 'yellow' ); 
$t->windowConfigure( "6,0", -sticky => 's', -window => $l ); 
  
# This is in the row titles 
$l = $top->Label( -text => "Window ne", -bg => 'yellow' ); 
$t->windowConfigure( "4,-1", -sticky => 'ne', -window => $l ); 
  
# This will get swallowed by a span 
$l = $top->Label( -text => "Window ew", -bg => 'yellow' ); 
$t->windowConfigure( "5,3", -sticky => 'ew', -window => $l ); 
  
# This is in the col titles 
$l = $top->Label( -text => "Window nsew", -bg => 'yellow' ); 
$t->windowConfigure( "-5,1", -sticky => 'nsew', -window => $l ); 
  
$l = $t->parent->Label( -text => "Sibling l", -bg => 'orange' ); 
$t->windowConfigure( "5,1", -sticky => 'nsew', -window => $l ); 
  
$t->spans( '-1,-2' => '0,3', '1,2' => '0,5', '3,2' => '2,2', '6,0' => '4,0' ); 
  
Tk::MainLoop;
Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
## edit_styles.pl 
## 
## demonstrates different edit styles within cells 
## 
## ewaldhei@idd.com 
  
## This script uses tags and some logic to simulate check 
##  buttons, browseEntries, etc in cells. This approach is 
##  faster than using embedded windows, especially for large 
##  tables. 
  
use Tk; 
use Tk::TableMatrix; 
  
main(); 
  
sub main { 
  my $top = MainWindow->new; 
  
  my $_data = {}; 
  my ( $rows, $cols ) = ( 12, 7 );    # number of rows/cols 
  
  # create the table 
  my $t = $top->Scrolled( 
    TableMatrix  => -rows => $rows, 
    -cols        => $cols, 
    -titlerows   => 1, 
    -titlecols   => 1, 
    -width       => 8, 
    -height      => 8, 
    -colwidth    => 11, 
    -variable    => $_data, 
    -cursor      => 'top_left_arrow', 
    -borderwidth => 2, 
    -ipadx       => 15, 
    -scrollbars  => 'se', 
  )->pack(qw/-expand 1 -fill both/); 
  
  my $tm = $t->Subwidget('scrolled'); 
  
  $tm->{columneditstyles} = { 
    qw(1 readonly 
      2 editable 
      3 button 
      4 optionmenu 
      5 browseentry 
      6 checkbutton 
      ) 
  }; 
  
  # set up tags for the various states of the buttons 
  $t->tagConfigure( 'OFF', -bg => 'gray60', -relief => 'raised' ); 
  $t->tagConfigure( 'ON',  -bg => 'gray80', -relief => 'sunken' ); 
  $t->tagConfigure( 'sel', -bg => 'gray70', -relief => 'flat' ); 
  $t->tagConfigure( 'readonly', -relief => 'groove' ); 
  
  my %images = define_bitmaps($top); 
  $t->tagConfigure( 
    'optionmenu', 
    -image    => $images{optionmenu}, 
    -anchor   => 'e', 
    -showtext => 1, 
  ); 
  $t->tagConfigure( 
    'browseentry', 
    -image    => $images{browseentry}, 
    -anchor   => 'e', 
    -showtext => 1 
  ); 
  $t->tagConfigure( 'checkbutton0', -image => $images{checkbutton0} ); 
  $t->tagConfigure( 'checkbutton1', -image => $images{checkbutton1} ); 
  
  $t->bind( '<Key-Escape>' => \&end_edit ); 
  
  # clean up if mouse leaves the widget 
  $t->bind( 
    '<FocusOut>', 
    sub { 
      my $w = shift; 
      $w->selectionClear('all'); 
      $w->configure( -state => 'disabled' ); 
    } 
  ); 
  
  # highlight the cell under the mouse 
  $t->bind( 
    '<Motion>', 
    sub { 
      my $w  = shift; 
      my $Ev = $w->XEvent; 
      if ( $w->selectionIncludes( '@' . $Ev->x . "," . $Ev->y ) ) { 
        Tk->break; 
      } 
      $w->selectionClear('all'); 
      $w->selectionSet( '@' . $Ev->x . "," . $Ev->y ); 
      Tk->break; 
      ## "break" prevents the call to TableMatrixCheckBorder 
    } 
  ); 
  
  # mousebutton 1 edits the cell (or not) appropriately 
  $t->bind( 
    '<1>', 
    sub { 
      my ($w) = @_; 
      withdraw_edit_widgets($w); 
      my $Ev = $w->XEvent; 
      my ( $x, $y ) = ( $Ev->x, $Ev->y ); 
      my $rc  = $w->index("\@$x,$y"); 
      my $var = $w->cget( -var ); 
      my ( $r, $c ) = split( /,/, $rc ); 
      $r && $c || return; 
      $w->{_b1_row_col} = "$r,$c"; 
      set_style_state($w); 
      my $style = $w->{columneditstyles}{$c} || 'editable'; 
  
      if ( $style eq 'optionmenu' || $style eq 'browseentry' ) { 
        setup_toplevel_lbox( $w, $r, $c ); 
      } 
      elsif ( $style eq 'button' ) { 
        my $newval = $var->{$rc} =~ /ON/ ? 'OFF' : 'ON'; 
        $var->{$rc} = $newval; 
        $w->tagCell( $newval, $rc ); 
      } 
      elsif ( $style eq 'checkbutton' ) { 
        $var->{$rc} = !$var->{$rc}; 
        my $tag = $var->{$rc} ? 'checkbutton1' : 'checkbutton0'; 
        $w->tagCell( $tag, $rc ); 
      } 
    } 
  ); 
  
  # replace std b1-release 
  $t->bind( 'Tk::TableMatrix' => '<ButtonRelease-1>', \&set_style_state ); 
  
  # inititialize the array, titles, and celltags 
  for ( my $r = 0; $r < $rows; $r++ ) { 
    for ( my $c = 0; $c < $cols; $c++ ) { 
      my $rc = "$r,$c"; 
      if ( !$r || !$c ) { 
        $_data->{$rc} = $r || $tm->{columneditstyles}{$c} || ""; 
      } 
      else { 
        $_data->{$rc} = $rc; 
        my $style = $tm->{columneditstyles}{$c} || 'editable'; 
        if ( $style eq 'readonly' ) { 
          $t->tagCell( 'readonly', $rc ); 
        } 
        if ( $style eq 'optionmenu' ) { 
          $_data->{$rc} = "$r options"; 
          $t->tagCell( 'optionmenu', $rc ); 
        } 
        elsif ( $style eq 'browseentry' ) { 
          $_data->{$rc} = "browse$r"; 
          $t->tagCell( 'browseentry', $rc ); 
        } 
        elsif ( $style eq 'button' ) { 
          $_data->{$rc} = $r % 4 ? 'ON' : 'OFF'; 
          $t->tagCell( $_data->{$rc}, $rc ); 
        } 
        elsif ( $style eq 'checkbutton' ) { 
          $_data->{$rc} = $r % 3 ? 0 : 1; 
          $t->tagCell( 'checkbutton' . $_data->{$rc}, $rc ); 
        } 
      } 
    } 
  } 
  
  Tk::MainLoop; 
} 
  
sub set_style_state { 
  my ($w) = @_; 
  my ( $r, $c ) = split( /,/, $w->{_b1_row_col} ); 
  if ( 
    grep( !$w->{columneditstyles}{$c} || $_ eq $w->{columneditstyles}{$c}, 
      qw(optionmenu readonly button checkbutton) ) 
    ) 
  { 
    $w->selectionClear('all'); 
    $w->configure( state => 'disabled' ); 
  } 
  else { 
    $w->configure( state => 'normal' ); 
    $w->activate( $w->{_b1_row_col} ); 
  } 
} 
  
sub end_edit { 
  my ($w) = @_; 
  $w->configure( -state => 'disabled' ); 
  $w->selectionClear('all'); 
} 
  
sub setup_toplevel_lbox { 
  my ( $w, $r, $c ) = @_; 
  
  my $toplevel = $w->{toplevel} ||= $w->Toplevel( -bd => 2, -relief => 'raised' ); 
  my $lbox = $toplevel->{lbox}; 
  $lbox->destroy() if $lbox; 
  $toplevel->overrideredirect(1); 
  
  my @options = map( chr( ord('A') + $_ - 1 ) x $_, 1 .. $r ); 
  my $height = @options > 8 ? 8 : ( @options || 1 ); 
  my $width = 2; 
  foreach (@options) { $width = length($_) if length($_) > $width; } 
  $lbox = $toplevel->{lbox} = $toplevel->Scrolled( 
    Listbox             => -height => $height, 
    -width              => $width + 1, 
    -relief             => 'raised', 
    -borderwidth        => 1, 
    -highlightthickness => 0, 
    -bg                 => $w->cget('bg'), 
    -scrollbars         => 'oe', 
  )->pack( -side => 'left' ); 
  
  $lbox->Subwidget('scrolled')->{_table_matrix} = $w; 
  
  $lbox->delete( 0, 'end' ); 
  $lbox->insert( 0, @options ); 
  
  my ( $gx, $gy ) = ( $w->rootx(), $w->rooty() ); 
  my @bbox = $w->bbox("$r,$c"); 
  my ( $mx, $my ) = ( int( $gx + $bbox[0] + $bbox[2] ), int( $gy + $bbox[1] ) ); 
  
  my $toplevel_ypixels 
    = $height * $bbox[3] + $toplevel->cget("-bd") * 2 + $toplevel->cget("-highlightthickness"); 
  
  my $y2 = $my + $toplevel_ypixels; 
  $my = $w->vrootheight - $toplevel_ypixels if ( $y2 > $w->vrootheight ); 
  
  $toplevel->transient( $w->toplevel() ); 
  $toplevel->geometry("+$mx+$my"); 
  $toplevel->deiconify(); 
  $toplevel->raise(); 
  
  $lbox->bind( 
    '<ButtonRelease-1>', 
    sub { 
      my ($lbox) = @_; 
      my $i      = $lbox->curselection(); 
      my $val    = $lbox->get($i); 
      my $w      = delete $lbox->{_table_matrix}; 
      my $rc     = delete $w->{_b1_row_col}; 
      my $var    = $w->cget( -var ); 
      $var->{$rc} = $val; 
      $w->set( $rc => $val ); 
      $w->selectionClear('all'); 
      $w->configure( -state => 'disabled' ); 
      withdraw_edit_widgets($w); 
    } 
  ); 
} 
  
sub withdraw_edit_widgets { 
  my ($w) = @_; 
  my $toplevel = $w->{toplevel}; 
  if ( $toplevel && $toplevel->state eq 'normal' ) { 
    $toplevel->withdraw(); 
  } 
} 
  
#-------------------------------------------------------------- 
  
sub define_bitmaps { 
  my ($w) = @_; 
  
  my $optionmenu = ' 
/* XPM */ 
static char * xpm[] = { 
"11 5 3 1", 
" 	c None", 
"+	c #D0D0D0", 
"@	c #555555", 
"+++++++++++", 
"++++++++++@", 
"++       @@", 
"++@@@@@@@@@", 
"+@@@@@@@@@@"}; 
'; 
  
  my $browseentry = ' 
/* XPM */ 
static char * xpm[] = { 
"11 7 3 1", 
" 	c None", 
"+	c #D0D0D0", 
"@	c #555555", 
"+++++++++++", 
"++++++++++@", 
"+++     @@@", 
" +++   @@@ ", 
"  +++ @@@  ", 
"   ++@@@   ", 
"    @@@    ", 
}; 
'; 
  
  my $cbutton0 = ' 
/* XPM */ 
static char * xpm[] = { 
"9 8 3 1", 
" 	c None", 
"@	c #B8B8B8", 
"+	c #555555", 
"+++++++++", 
"++++++++@", 
"++     @@", 
"++     @@", 
"++     @@", 
"++     @@", 
"++@@@@@@@", 
"+@@@@@@@@"}; 
}; 
'; 
  
  my $cbutton1 = ' 
/* XPM */ 
static char * xpm[] = { 
"9 8 4 1", 
" 	c None", 
"@	c #B8B8B8", 
"+	c #555555", 
".	c #FF0000", 
"+++++++++", 
"++++++++@", 
"++.....@@", 
"++.....@@", 
"++.....@@", 
"++.....@@", 
"++@@@@@@@", 
"+@@@@@@@@"}; 
}; 
'; 
  
  my %images; 
  $images{optionmenu}   = $w->Pixmap( 'optionmenu',  -data => $optionmenu ); 
  $images{browseentry}  = $w->Pixmap( 'browseentry', -data => $browseentry ); 
  $images{checkbutton0} = $w->Pixmap( 'cbutton0',    -data => $cbutton0 ); 
  $images{checkbutton1} = $w->Pixmap( 'cbutton1',    -data => $cbutton1 ); 
  %images; 
}
Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
########## 
### Demo of using embedded windows in TableMatrix 
  
###  This works well, but can be slow for very large tables with many 
###   windows. 
### 
###  See edit_styles.pl for an alternative that is faster for larger 
###    tables 
  
use Tk; 
use Tk::BrowseEntry; 
use Tk::TableMatrix; 
  
use Data::Dumper qw( DumperX); 
my $top = MainWindow->new; 
  
my $arrayVar = {}; 
  
foreach my $row ( 0 .. 20 ) { 
  foreach my $col ( 0 .. 10 ) { 
    $arrayVar->{"$row,$col"} = "r$row, c$col"; 
  } 
} 
  
my $t = $top->Scrolled( 
  'TableMatrix', 
  -rows          => 21, 
  -cols          => 11, 
  -width         => 6, 
  -height        => 6, 
  -titlerows     => 1, 
  -titlecols     => 1, 
  -variable      => $arrayVar, 
  -selectmode    => 'extended', 
  -resizeborders => 'both', 
  -titlerows     => 1, 
  -titlecols     => 1, 
  -bg            => 'white', 
  
  #  -state => 'disabled' 
  #  -colseparator => "\t", 
  #  -rowseparator => "\n" 
); 
  
$t->tagConfigure( 'active', -bg => 'gray90', -relief => 'sunken' ); 
$t->tagConfigure( 'title', -bg => 'gray85', -fg => 'black', -relief => 'sunken' ); 
  
################ Put in some embedded windows ################ 
my $l = $top->Checkbutton( -text => 'CheckButton' ); 
$t->windowConfigure( "3,3", -sticky => 's', -window => $l ); 
  
my $c = $top->BrowseEntry( -label => "Month:" ); 
$c->insert( "end", "January" ); 
$c->insert( "end", "February" ); 
$c->insert( "end", "March" ); 
$c->insert( "end", "April" ); 
$c->insert( "end", "May" ); 
$c->insert( "end", "June" ); 
$c->insert( "end", "July" ); 
$c->insert( "end", "August" ); 
$c->insert( "end", "September" ); 
$c->insert( "end", "October" ); 
$c->insert( "end", "November" ); 
$c->insert( "end", "December" ); 
  
$t->windowConfigure( "2,2", -sticky => 'ne', -window => $c ); 
  
# Leave enough room for the windows 
$t->colWidth( 2, 20 ); 
$t->colWidth( 3, 20 ); 
  
$t->pack( -expand => 1, -fill => 'both' ); 
  
Tk::MainLoop;
Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
## maxsize.tcl 
## 
## This demo uses a really big table.  The big startup time is in 
## filling the table's Tcl array var. 
## 
## jeff.hobbs@acm.org 
## Converted to perl/tk by John Cerney 7/24/00 
  
use Tk; 
  
use Tk::TableMatrix; 
  
my $top = MainWindow->new; 
  
my $arrayVar = {}; 
  
print "Filling Array...\n"; 
my ( $rows, $cols ) = ( 40000, 10 ); 
foreach my $row ( 0 .. ( $rows - 1 ) ) { 
  foreach my $col ( 0 .. ( $cols - 1 ) ) { 
    $arrayVar->{"$row,$col"} = "$row,$col"; 
  } 
} 
  
print "Creating Table...\n"; 
## Test out the use of a callback to define tags on rows and columns 
sub colSub { 
  my $col = shift; 
  return "OddCol" if ( $col > 0 && $col % 2 ); 
} 
  
my $label = $top->Label( -text => "TableMatrix v2 Example" ); 
  
my $t = $top->Scrolled( 
  'TableMatrix', 
  -rows           => $rows, 
  -cols           => $cols, 
  -width          => 6, 
  -height         => 6, 
  -titlerows      => 1, 
  -titlecols      => 1, 
  -variable       => $arrayVar, 
  -coltagcommand  => \&colSub, 
  -colstretchmode => 'last', 
  -rowstretchmode => 'last', 
  -selectmode     => 'extended', 
  -selecttitles   => 0, 
  -drawmode       => 'slow', 
); 
  
my $button = $top->Button( -text => "Exit", -command => sub { $top->destroy } ); 
  
# hideous Color definitions here: 
$t->tagConfigure( 'OddCol', -bg => 'brown', -fg => 'pink' ); 
$t->tagConfigure( 'title', -bg => 'red', -fg => 'blue', -relief => 'sunken' ); 
$t->tagConfigure( 'dis', -state => 'disabled' ); 
  
my $i     = -1; 
my $first = $t->cget( -colorigin ); 
my $anchor; 
foreach $anchor (qw/ n s e w nw ne sw se c /) { 
  $t->tagConfigure( $anchor, -anchor => $anchor ); 
  $t->tagRow( $anchor, ++$i ); 
  $t->set( "$i,$first", $anchor ); 
} 
$top->fontCreate( 'courier', -family => 'courier', -size => 10 ); 
$t->tagConfigure( 's', -font => 'courier', -justify => 'center' ); 
  
$t->colWidth( -2 => 8, -1 => 9, 0 => 12, 4 => 14 ); 
  
$label->pack( -expand => 1, -fill => 'both' ); 
  
$t->pack( -expand => 1, -fill => 'both' ); 
$button->pack( -expand => 1, -fill => 'both' ); 
  
Tk::MainLoop;
Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
## spreadsheet.tcl 
## 
## This demos shows how you can simulate a 3D table 
## and has other basic features to begin a basic spreadsheet 
## 
## jeff.hobbs@acm.org 
##  Converted to perl/tk by John Cerney 
  
use Tk; 
  
use Tk::TableMatrix; 
  
my ( $rows, $cols ) = ( 10, 10 );    # number of rows/cols 
my $page    = 'AA'; 
my $oldPage = ''; 
  
my $tableColors = { default => 'pink', AA => 'orange', BB => 'blue', CC => 'green' }; 
  
my $top = MainWindow->new; 
  
sub colorize { 
  my ($num) = @_; 
  return 'colored' if ( $num > 0 && $num % 2 ); 
  return ''; 
} 
  
# Sub to fill the array variable 
sub fill { 
  
  my ( $name, $array, $r, $c ) = @_; 
  my ( $i, $j ); 
  $r ||= $rows; 
  $c ||= $cols; 
  for ( $i = 0; $i < $r; $i++ ) { 
    for ( $j = 0; $j < $c; $j++ ) { 
      if ( $j && $i ) { 
        $array->{"$i,$j"} = "$name $i,$j"; 
      } 
      elsif ($i) { 
        $array->{"$i,$j"} = "$i"; 
      } 
      elsif ($j) { 
        $array->{"$i,$j"} = sprintf( "%c", ( $j + 64 ) ); 
      } 
    } 
  } 
} 
  
my $arrayVar = { 
  AA => {}, 
  BB => {}, 
  CC => {} 
}; 
  
fill( 'AA', $arrayVar->{AA}, $rows,     $cols );        # fill up the array variable 
fill( 'BB', $arrayVar->{BB}, $rows / 2, $cols / 2 );    # fill up the array variable 
  
my $t = $top->Scrolled( 
  'TableMatrix', 
  -rows          => $rows, 
  -cols          => $cols, 
  -width         => 5, 
  -height        => 5, 
  -titlerows     => 1, 
  -titlecols     => 1, 
  -coltagcommand => \&colorize, 
  -selectmode    => 'extended', 
  -flashmode     => 'on', 
  -variable      => $arrayVar->{$page}, 
  
); 
  
my $label = $top->Label( -text => "TableMatrix vs Spreadsheet Example" ); 
  
# Label the changes with the value of currentTest 
my $currentText = ''; 
my $currentLabel = $top->Label( -textvariable => \$currentText ); 
  
# Entry that changes with the value of activeText 
my $activeText = ''; 
my $activeEntry = $top->Entry( -textvariable => \$activeText ); 
  
my $pageLabel = $top->Label( -text => 'PAGE:', -width => 6, -anchor => 'e' ); 
my $pageSelect = $top->Optionmenu( 
  -options  => [qw/ AA BB CC/], 
  -variable => \$page, 
  -command  => [ \&changepage ] 
); 
  
sub changepage { 
  
  my ($newPage) = @_; 
  
  if ( $newPage ne $oldPage ) { 
  
    $t->selectionClear('all'); 
    $t->activate('');    # unactivate anything 
    $t->configure( -variable => $arrayVar->{$newPage} ); 
  
    # $e config -textvar ${i}(active) 
    $t->activate('origin'); 
    if ( exists $tableColors->{$newPage} ) { 
      $t->tagConfigure( 'colored', -bg => $tableColors->{$newPage} ); 
    } 
    else { 
      $t->tagConfigure( 'colored', -bg => $tableColors->{'default'} ); 
    } 
    $t->see('active'); 
    $oldPage = $newPage; 
  } 
} 
  
$t->configure( 
  -browsecommand => sub { 
    my ( $oldindex, $index ) = @_; 
    $currentText = $index; 
    $activeText  = $t->get($index); 
  } 
); 
  
# hideous Color definitions here: 
$t->tagConfigure( 'colored', -bg => $tableColors->{$page} ); 
$t->tagConfigure( 'title',   -fg => 'red', -relief => 'groove' ); 
$t->tagConfigure( 'blue',    -bg => 'blue' ); 
$t->tagConfigure( 'green',   -bg => 'green' ); 
  
$t->tagCell( 'green', '6,3', '5,7', '4,9' ); 
$t->tagCell( 'blue', '8,8' ); 
$t->tagRow( 'blue', 7 ); 
$t->tagCol( 'blue', 6, 8 ); 
  
$t->colWidth( 0 => 3, 2 => 7 ); 
  
$label->grid( '-', '-', '-', '-', '-sticky' => 'ew' ); 
$currentLabel->grid( $currentLabel, $activeEntry, $pageLabel, $pageSelect, '-', '-sticky' => 'ew' ); 
$t->grid( '-', '-', '-', '-', '-sticky' => 'nsew' ); 
$top->gridColumnconfigure( 1, -weight => 1 ); 
$top->gridRowconfigure( 2, -weight => 1 ); 
  
Tk::MainLoop;
Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
# Script show tag merging behavior with an option set in the 
#  option database. 
# 
#   Should display with one row hightlighted red and a cell in the row left-justified 
  
use Tk; 
use Tk::TableMatrix; 
  
use strict; 
  
my $mw = MainWindow->new; 
  
#$mw->optionAdd('*background', 'blue', 'interactive'); 
$mw->optionAdd( '*tablematrix*background', 'skyblue' ); 
  
my $table = $mw->TableMatrix( 
  -rows  => 5, 
  -cols  => 8, 
  -cache => 1, 
  
  #-bg => 'blue', 
); 
$table->pack( -expand => 1, -fill => 'both' ); 
  
foreach my $row ( 0 .. 4 ) { 
  
  #$table->tagRow('invalid', $row);                # swap 
  foreach my $column ( 0 .. 7 ) { 
    $table->set( "$row,$column", "hello" ); 
  
    #$table->tagCell('left', "$row,$column");    # swap 
  } 
} 
  
# 'invalid' tag takes priority of 'left' tag, because it is created first, 
#     so the cell 2,3 should be red and center anchored, but see below... 
$table->tagConfigure( "invalid", -background => 'red',   -anchor => 'center' ); 
$table->tagConfigure( "left",    -background => 'green', -anchor => 'w' ); 
  
$table->tagCell( 'left', '2,3' ); 
$table->tagRow( 'invalid', 2 ); 
  
#  The tag priority is changed, so the cell 2,3 will be gree and 'w' achored. 
$table->tagRaise( 'left', 'invalid' ); 
  
# This would have the same effect as the above tagRaise 
#$table->tagLower('invalid', 'left'); 
  
MainLoop;
Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
# Script show the new multi-number borderwidth option for tags 
#   Borderwidth can be specified as a space separated list of 
#     4 numbers representing left right top bottom borders drawn in a cell 
# 
#   In this example, the tag'ed row will have a large top/bottom border, and a normal 
#     size left/right border 
  
use Tk; 
use Tk::TableMatrix; 
  
use strict; 
  
my $mw = MainWindow->new; 
  
#$mw->optionAdd('*background', 'blue', 'interactive'); 
$mw->optionAdd( '*tablematrix*background', 'skyblue' ); 
  
my $table = $mw->TableMatrix( 
  -rows  => 5, 
  -cols  => 8, 
  -cache => 1, 
  
  #-bg => 'blue', 
); 
$table->pack( -expand => 1, -fill => 'both' ); 
  
$table->tagConfigure( "invalid", -background => 'red', -relief => 'raised', -bd => '1 1 5 5' ); 
$table->tagConfigure( "left", -anchor => 'w' ); 
  
foreach my $row ( 0 .. 4 ) { 
  
  #$table->tagRow('invalid', $row);                # swap 
  foreach my $column ( 0 .. 7 ) { 
    $table->set( "$row,$column", "hello" ); 
  
    #$table->tagCell('left', "$row,$column");    # swap 
  } 
} 
  
$table->tagCell( 'left', '2,3' ); 
$table->tagRow( 'invalid', 2 ); 
  
MainLoop;

Mis à jour le 14 avril 2011 djibril

Proposer une nouvelle réponse sur la FAQ

Ce n'est pas l'endroit pour poser des questions, allez plutôt sur le forum de la rubrique pour ça


Réponse à la question

Liens sous la question
précédent sommaire suivant
 

Les sources présentées sur cette page sont libres de droits et vous pouvez les utiliser à votre convenance. Par contre, la page de présentation constitue une œuvre intellectuelle protégée par les droits d'auteur. Copyright © 2019 Developpez Developpez LLC. Tous droits réservés Developpez LLC. Aucune reproduction, même partielle, ne peut être faite de ce site et de l'ensemble de son contenu : textes, documents et images sans l'autorisation expresse de Developpez LLC. Sinon vous encourez selon la loi jusqu'à trois ans de prison et jusqu'à 300 000 € de dommages et intérêts.