FAQ Perl/TkConsultez toutes les FAQ

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
#!/usr/bin/perl 
use warnings; 
use strict; 
use Tk;    # Appel du module Tk 
  
my $fenetre = new MainWindow( 
  -title      => "Première fenêtre Tk ", 
  -background => "white", 
);  
  
# Affichage d'un bouton pour fermer la fenêtre 
my $bouton = $fenetre->Button ( 
    -text    => "Détruire la fenêtre",  
-command => \&DestructionFenetre, 
)->pack(); 
  
MainLoop;  # Obligatoire 
  
sub DestructionFenetre {  
  $fenetre->TOTO;  # => On introduit délibérément une erreur car la méthode TOTO n'existe pas 
  exit; 
  
  return;  
}  
  
#================================================ 
# But : Afficher les messages d'erreurs dans une fenêtre 
# Arguments : rien 
# Retour    : Rien 
#================================================ 
sub Tk::Error { 
  my ( $widget, $Error, @Locations ) = @_; 
  
  # Error widget 
  my $MwError = $widget->Toplevel( -background => "white" ); 
  $MwError->title( "Fenêtre d'erreurs" ); 
  $MwError->minsize( 300, 300 ); 
  $MwError->grab(); 
  
  my $MessageError = $MwError->Scrolled( "Text", -scrollbars => "oe" ); 
  $MessageError->delete( "1.0", "end" ); 
  $MessageError->insert( "end", "Erreur : $Error\n\n" ); 
  #$MessageError->insert( "end", "Location : @Locations\n\n" ); 
  #$MessageError->insert( "end", "Widget : $widget\n" ); 
  
  $MessageError->pack( -fill => "both", -expand => 1, ); 
  
  return; 
}

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
#!/usr/bin/perl 
use warnings; 
use strict; 
  
use Tk; 
  
my $mw = MainWindow->new; 
  
my $Scrolled = $mw->Text( 
      -height     => 10, 
      -wrap       => "none", 
      -relief     => "solid", 
      -background  => "white", 
    )->pack(-fill => "both", -expand => 1); 
  
 tie *STDOUT, ref $Scrolled, $Scrolled; 
  
print "Hello Text World!\n\n"; 
print "ceci est un test\n\n"; 
  
MainLoop;

1
2
3
4
5
6
7
my $Directory = $widget->chooseDirectory( 
  -title      => "Mon titre",   # Titre fenêtre 
  -initialdir => "C:/",         # Répertoire par défaut 
  -mustexist  => 1,             # Le répertoire sélectionné doit exister 
); 
  
print $Directory;

1
2
3
4
5
# Windows 
  my $OS = lc($^O); 
  if ( $OS eq 'mswin32' ) { 
    $Directory = encode( 'iso-8859-1', $Directory ); 
  }

1
2
3
4
5
6
my @TabFiles = $widget->getOpenFile( 
  -initialdir => "C:/", 
  -multiple   => 1, 
); 
  
print "@TabFiles";

1
2
3
4
5
my $File = $widget->getOpenFile( 
    -initialdir => "C:/", 
); 
  
print $File;

1
2
3
4
5
6
7
8
9
my $types = [  
	[ 'Fichiers log', '.log' ], 
	['Tous les fichiers',    '*'] 
]; 
  
my $filename = $widget->getOpenFile( 
    -filetypes  => $types, 
    -initialdir => "." 
  );

1
2
3
4
5
# Windows 
  my $OS = lc($^O); 
  if ( $OS eq 'mswin32' ) { 
    $File = encode( 'iso-8859-1', $File ); 
  }

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
#!/usr/bin/perl 
use warnings; 
use strict; 
use Tk; 
use Tk::Dropsite 'Win32'; 
use File::Basename; 
use utf8; 
  
my $mw = MainWindow->new( -background => '#E0F0FF', ); 
  
$mw->Label( 
  -text       => 'Faire un glisser-déposer de fichiers ou répertoires dans le widget ci-dessous', 
  -background => '#E0F0FF', 
)->pack(qw/ -side top -pady 2/); 
  
my $widgetTextDragDrop = $mw->Scrolled( 
  'Text', 
  -background => 'white', 
  -scrollbars => 'osoe', 
  -wrap       => 'none', 
  -height     => 7, 
)->pack(qw/ -side top -pady 2/); 
  
$mw->Label( 
  -text       => 'Résultat', 
  -background => '#E0F0FF', 
)->pack(qw/ -pady 2/); 
  
my $widgetTextResultat = $mw->Scrolled( 
  'Text', 
  -background => 'white', 
  -scrollbars => 'osoe', 
  -wrap       => 'none', 
)->pack(qw/ -pady 2 -fill both -expand 1/); 
  
# Conception du glisser-déposer 
$widgetTextDragDrop->DropSite( 
  -dropcommand => [ \&ActionDrop, $widgetTextDragDrop, $widgetTextResultat ], 
  -droptypes   => 'Win32', 
); 
  
MainLoop; 
  
sub ActionDrop { 
  my ( $widgetTextDragDrop, $widgetTextResultat ) = @_; 
  
  my $sel = $widgetTextDragDrop->SelectionGet( -selection => 'CLIPBOARD' ); 
  foreach my $fichier_rep ( split( /\n/, $sel ) ) { 
    $widgetTextDragDrop->insert( 'end', "$fichier_rep\n" ); 
    $widgetTextResultat->insert( 'end', "$fichier_rep\n" ); 
    if ( -d $fichier_rep ) { 
      $widgetTextResultat->insert( 'end', "\tRépertoire : $fichier_rep\n" ); 
    } 
    elsif ( -f $fichier_rep ) { 
      $widgetTextResultat->insert( 'end', 
        "\tFichier : (" . dirname($fichier_rep) . ', ' . basename($fichier_rep) . ")\n" ); 
    } 
  } 
  return; 
}

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
#!/usr/bin/perl 
use warnings; 
use strict; 
use Tk; 
use Tk::MiniCalendar; 
  
my $fenetre = new MainWindow( -title => 'Calendrier Tk', ); 
$fenetre->minsize( 300, 300 ); 
  
my @tab_date = localtime(time); 
my $Jour     = $tab_date[3]; 
my $Mois     = $tab_date[4] + 1; 
my $Annee    = $tab_date[5] + 1900; 
  
my $CalendrierWidget = $fenetre->MiniCalendar( 
  -day         => $Jour, 
  -month       => $Mois, 
  -year        => $Annee, 
  -day_names   => [ 'Lu', 'M', 'Me', 'Je', 'V', 'Sam', 'Dim' ], 
  -month_names => [ 
    'Janvier', 'Février', 'Mars',      'Avril',   'Mai',      'Juin', 
    'Juillet', 'Août',    'Septembre', 'Octobre', 'Novembre', 'Décembre' 
  ], 
)->pack; 
  
my $date = 'Aucune date sélectionnée'; 
$fenetre->Label( -textvariable => \$date, )->pack; 
  
$fenetre->Button( 
  -text    => 'Date selectionnée ?', 
  -command => sub { 
    my ( $Annee, $Mois, $Jour ) = $CalendrierWidget->date; 
    $date = "Date après clic : $Jour/$Mois/$Annee\n"; 
  }, 
)->pack; 
  
MainLoop;

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
# ================================================ 
# But: exécuter régulièrement une action, comme donner une heure 
# Argument: le widget dans lequel placer (mainwindow ou autre) 
# Attention, j'appelle le PACK, mais ça doit correspondre avec le widget parent 
# Exemple d'appel: $mw=MainWindow... UneCaseHorlogePack($mw) 
# ================================================ 
  
  
sub UneCaseHorlogePack { 
  my $parent = shift ; 
  unless ($parent->IsWidget) { die "Erreur: mauvais appel, ce n'est pas un widget\n"; } 
  my $menubar = $parent->Frame(-relief => 'raised', -borderwidth => 2)-> pack(); 
  
  # avec quelle fréquence je mets à jour 
  my $FREQUENCY      = 1000 ;	# millisecondes: 60000 = 1 min 
  
  # zone d'affichage de l heure 
  # on peut avoir Label ou Button 
  my $horloge=$menubar->Label(  
		-font => "dtinfo"  , 
		-text => "mon horloge"  , 
		-height=>'1' , 
		-background => "black", 
		-foreground => "white", 
		-width=>30, 
		-justify =>'center', 
		) -> pack(); 
  
   # ce frame appelle régulièrement une fonction 
   $menubar->repeat( $FREQUENCY, [\&UpdateTimeNow ,$horloge] ); 
} 
  
# la fonction qui s'exécute régulièrement 
sub UpdateTimeNow {  
   my $horloge = shift ; 
   # attraper l'heure machine 
   my $now= localtime(time) ; 
   # puis l'afficher dans la zone prévue  
   $horloge->configure(-text => $now ); 
   # remarque: il est possible de l'afficher dans le bandeau fenêtre de l'application 
   # $mw->title($now) 
   # remarque: en général, je fais plein de trucs ici, régulièrement, pour des tableaux de bord 
}

1
2
3
4
5
6
7
8
9
#!/usr/bin/perl 
use Tk; 
use strict; 
use warnings; 
  
my $mw = MainWindow->new( -background => "white" ); 
UneCaseHorlogePack($mw); 
  
...

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
#!/usr/bin/perl 
use strict; 
use warnings; 
  
use Tk; 
  
my $mw = MainWindow->new( 
  -title      => "Couleurs", 
  -background => 'white' 
); 
  
my $Anim = $mw->Button( 
  -text    => 'Select color with chooseColor', 
  -command => sub { 
    my $couleur = $mw->chooseColor( -title => 'Choisir couleur' ); 
    $mw->configure( -background => $couleur ); 
  }, 
)->pack(qw/ -pady 10 -padx 10/); 
  
MainLoop;