UNIT Upattern; {----------------------------------------------------------------------------- NOM DE L'UNITE : UPATTERN.PAS BUT : Test de transmission entre les différents ports du PPI 8255 AUTEUR : Stéphane Claus DATE : Décembre 1996 MODIFIE LE : 12.04.1997 - EDT:01 RAISON : - Ajout de commentaires - Ajout du paramètre SansAjoutListe à la procédure AjouteErreur -----------------------------------------------------------------------------} {=============================================================================} INTERFACE {============================================== I N T E R F A C E } {=============================================================================} USES SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, DigDisp, StdCtrls, Buttons, ExtCtrls; TYPE TfrmPattern = CLASS(TForm) digdspTitre: TDigitalDisplay; bitbtnOK: TBitBtn; bitbtnAide: TBitBtn; rgrpPorts: TRadioGroup; GroupBox1: TGroupBox; bitbtnStart: TBitBtn; bitbtnStop: TBitBtn; grpbxInformations: TGroupBox; lstbxListeErreurs: TListBox; lblLstErreurs: TLabel; lblOK0: TLabel; lblKO0: TLabel; lblTotal0: TLabel; lblOK1: TLabel; lblKO1: TLabel; lblTotal1: TLabel; Bevel1: TBevel; lblNombreTransmissions: TLabel; PROCEDURE FormActivate(Sender: TObject); PROCEDURE bitbtnStartClick(Sender: TObject); PROCEDURE bitbtnStopClick(Sender: TObject); PROCEDURE FormClose(Sender: TObject; VAR Action: TCloseAction); PROCEDURE bitbtnOKClick(Sender: TObject); PRIVATE { Private-déclarations } PUBLIC { Public-déclarations } NbTransfertsOK : LONGINT; NbTransfertsKO : LONGINT; NbTransfertsTot : LONGINT; Pour100OK : INTEGER; Pour100KO : INTEGER; PROCEDURE RAZCompteurs(Sender:TObject); PROCEDURE AjouteErreur(Sender:TObject; SansAjoutListe: BOOLEAN); END; {CLASS} VAR frmPattern: TfrmPattern; {=============================================================================} IMPLEMENTATION {================================= I M P L E M E N A T I O N } {=============================================================================} {$R *.DFM} USES UPrincpl, VCL8255; PROCEDURE TfrmPattern.RAZCompteurs(Sender:TObject); {----------------------------------------------------------------------------- BUT ........... : Réinitialise les compteurs d'erreurs ENTREE ........ : -- SORTIE ........ : -- EFFETS DE BORDS : -- REMARQUE(S) ... : -- -----------------------------------------------------------------------------} BEGIN lblOK1.Caption := ''; lblKO1.Caption := ''; lblTotal1.Caption := ''; lstbxListeErreurs.Clear; NbTransfertsOK := 0; NbTransfertsKO := 0; NbTransfertsTot := 0; Pour100OK := 0; Pour100KO := 0; END; {PROCEDURE RAZCompteurs} PROCEDURE TfrmPattern.AjouteErreur(Sender:TObject; SansAjoutListe: BOOLEAN); {----------------------------------------------------------------------------- BUT ........... : Ajoute à la liste la nouvelle erreur détectée et met à jour le panel Informations ENTREE ........ : SansAjoutListe = Si ce paramètre est à TRUE, seuls les infos sur les transferts sont affichés. S'il est à FALSE, le message d'erreur du à une erreur est ajuté à la liste. SORTIE ........ : -- EFFETS DE BORDS : C'est décrit dans le but REMARQUE(S) ... : Ajout du paramètre "SansAjoutListe: BOOLEAN" dans l'EDT:01 -----------------------------------------------------------------------------} VAR Temp : REAL; BEGIN { Lit où on en est } NbTransfertsOK := frmMain.PPI8255.PatternNbOK; NbTransfertsKO := frmMain.PPI8255.PatternNbErreurs; { Calcul ne nombre total de transferts } NbTransfertsTot := NbTransfertsKO + NbTransfertsOK; { Conversion en % } Temp := 100 / NbTransfertsTot; Pour100OK := Round(NbTransfertsOK * Temp); Pour100KO := 100 - Pour100OK; { Affichage des informations } lblOK1.Caption := IntToStr(NbTransfertsOK); lblKO1.Caption := IntToStr(NbTransfertsKO); lblTotal1.Caption := IntToStr(NbTransfertsTot); { S'il on peut encore ajouter un message d'erreur à la liste, on le fait, sinon le message est perdu. Le nombre maximum d'éléments dans une liste est de 16380. On s'arrête à 10'000, car c'est amplement suffisant pour notre test. } {EDT:01 N'ajoute que si SansAjoutListe est à FALSE } IF ((lstbxListeErreurs.Items.Count <= 10000) AND (NOT SansAjoutListe)) THEN BEGIN { Liste pas encore complète et ajout du message demandé } lstbxListeErreurs.Items.Add(frmMain.PPI8255.PatternMessage) END; {IF} END; {PROCEDURE AjouteErreur} PROCEDURE TfrmPattern.FormActivate(Sender: TObject); {----------------------------------------------------------------------------- BUT ........... : Initialisation de la fiche en fonction des paramètres actuels du programme ENTREE ........ : -- SORTIE ........ : -- EFFETS DE BORDS : -- REMARQUE(S) ... : -- -----------------------------------------------------------------------------} BEGIN Caption := Application.Title; { Titre de la fenêtre } IF debugmode THEN Color := debugcolor { Couleur de la fenêtre } ELSE Color := clBtnFace; rgrpPorts.ShowHint := affichehint; { Affichage des Hint } bitbtnStart.ShowHint := affichehint; bitbtnStop.ShowHint := affichehint; lblOK1.ShowHint := affichehint; lblKO1.ShowHint := affichehint; lblTotal1.ShowHint := affichehint; lstbxListeErreurs.ShowHint := affichehint; RAZCompteurs(Sender); { Reset des erreurs } END; {PROCEDURE FormActivate} PROCEDURE TfrmPattern.bitbtnStartClick(Sender: TObject); { BUT: Démarre le test pattern } {----------------------------------------------------------------------------- BUT ........... : ENTREE ........ : -- SORTIE ........ : -- EFFETS DE BORDS : -- REMARQUE(S) ... : -- -----------------------------------------------------------------------------} BEGIN {-- Désactive les contrôles génants } rgrpPorts.Enabled := FALSE; bitbtnStart.Enabled := FALSE; {-- RAZ des compteurs } RAZCompteurs(Sender); {-- Choix des ports à utiliser } CASE rgrpPorts.ItemIndex OF 0 : frmMain.PPI8255.PatternPorts := ppABC; 1 : frmMain.PPI8255.PatternPorts := ppBAC; 2 : frmMain.PPI8255.PatternPorts := ppCAB; 3 : frmMain.PPI8255.PatternPorts := ppAB; 4 : frmMain.PPI8255.PatternPorts := ppAC; 5 : frmMain.PPI8255.PatternPorts := ppBA; 6 : frmMain.PPI8255.PatternPorts := ppBC; 7 : frmMain.PPI8255.PatternPorts := ppCA; 8 : frmMain.PPI8255.PatternPorts := ppCB; END; {CASE OF} {-- Démarre le test } IF NOT debugmode THEN BEGIN frmMain.PPI8255.Pattern; END; {IF} END; {PROCEDURE bitbtnStartClick} PROCEDURE TfrmPattern.bitbtnStopClick(Sender: TObject); {----------------------------------------------------------------------------- BUT ........... : Arrête le test pattern et affiche les statistiques des transferts effectués ENTREE ........ : -- SORTIE ........ : -- EFFETS DE BORDS : -- REMARQUE(S) ... : -- -----------------------------------------------------------------------------} VAR Temp : REAL; BEGIN {-- Arrête le test} frmMain.PPI8255.PatternStop := TRUE; {-- Réactive les contrôles génants } rgrpPorts.Enabled := TRUE; bitbtnStart.Enabled := TRUE; {-- On en est ou avec les erreurs ?? } NbTransfertsOK := frmMain.PPI8255.PatternNbOK; NbTransfertsKO := frmMain.PPI8255.PatternNbErreurs; NbTransfertsTot := NbTransfertsKO + NbTransfertsOK; IF NbTransfertsTot > 0 THEN BEGIN (*EDT:01 Simplification... Temp := 100 / NbTransfertsTot; Pour100OK := Trunc(NbTransfertsOK * Temp); Pour100KO := 100 - Pour100OK; lblOK1.Caption := IntToStr(NbTransfertsOK); lblKO1.Caption := IntToStr(NbTransfertsKO); lblTotal1.Caption := IntToStr(NbTransfertsTot); *) AjouteErreur(Sender, TRUE); END; {IF} END; {PROCEDURE bitbtnStopClick} PROCEDURE TfrmPattern.FormClose(Sender: TObject; VAR Action: TCloseAction); {----------------------------------------------------------------------------- BUT ........... : S'assure que le test est arrêté lors de la fermeture de la fiche ENTREE ........ : -- SORTIE ........ : -- EFFETS DE BORDS : -- REMARQUE(S) ... : -- -----------------------------------------------------------------------------} BEGIN bitbtnStopClick(Sender); END; {PROCEDURE FormClose} PROCEDURE TfrmPattern.bitbtnOKClick(Sender: TObject); {----------------------------------------------------------------------------- BUT ........... : Arrête le test de pattern et referme cette boîte de dialogue ENTREE ........ : -- SORTIE ........ : -- EFFETS DE BORDS : -- REMARQUE(S) ... : -- -----------------------------------------------------------------------------} BEGIN bitbtnStopClick(Sender); Close; END; {PROCEDURE bitbtnOKClick} {=============================================================================} { INITIALISATIONS ------------------------------------------- Initialisations } {=============================================================================} INITIALIZATION END. {UNIT Upattern}