DP Tool Club 19/CD_ASCQ_19_010295.iso/dos/prg/pas/ktools/source/kmenu.pas

Pascal/Delphi Source File | 1994-11-02 | 15KB | 656 lines

Program KMenu2;
{ Lanceur d'applications à partir d'un fichier Batch. }
{ K.B. mai-novembre 1994 }

{.$DEFINE debug}

{$IFDEF debug}
 {$A+,B-,D+,E-,F-,I+,L+,N-,R+,S+,V-,W+,X+}
{$ELSE}
 {$A+,B-,D-,E-,F-,I+,L-,N-,R-,S-,V-,W+,X+}
{$ENDIF}

Uses Dos,
     UDrivers,UTextScr,UMem,
     OTableau,
     OGenView,OTxtView,ODialWin;

Const
 NomFichierBatch='ktmp!!!!.bat';
 nbrNiv=5;
 MaxLenItem=35;
 DelaiRepos=60;

 cmKMenu=$200;   {évènement charge fenêtre menu}
 cmAbout=$201;
 cmPassWord=$202;
 cmRepos=$203;

Type

 PKMenuItem=^TKmenuItem;
 TKmenuItem=object(TStrTab)
  Titre:String[MaxLenItem];
  Constructor Init(T:String);
  Procedure FaireFichierBatch;
  Function GetNewMenu:TStr12;
  Function IsNewMenu:Boolean;
  End;

 PKMenuTab=^TKMenuTab;
 TKMenuTab=object(TTabPtr)
  Constructor Init;
  Procedure Effacer(p:Pointer);virtual;
  Function DonneItem(n:Integer):PKMenuItem;
  Function DonneTitre(n:Integer):String;
  End;

 PKMenuWin=^TKmenuWin;
 TKMenuWin=object(TWindow)
  Items:TKmenuTab;
  Choix:Integer;
  Constructor Init(NomFichier:PathStr);
  Destructor Done;virtual;
  Procedure HandleEvent(Var Event:TEvent);virtual;
  Procedure DrawInterior;virtual;
  Procedure LireDatas(NomFichier:PathStr);
  Procedure SauverDatas(NomFichier:PathStr);
  Function Ligne(n:Integer):String;
  Function NombreItems:Integer;
  Function NumeroChoisi(P:TPoint):Integer;
  End;

 PKMenuApp=^TKmenuApp;
 TKMenuApp=object(TTextApp)
  MotDePasse:TStr12;
  TabNiv: array[1..nbrNiv] of TStr12;
  Niveau:Byte;
  TimeCount:LongInt;
  Constructor Init;
  Procedure HandleEvent(Var Event:TEvent); virtual;
  Procedure TempsMort; virtual;
  Procedure ChangeWin;
  Function TestPassWord:Boolean;
  Procedure LireNiveau;
  Procedure EcrireNiveau;
  Function ConfirmExit:Boolean;
  Procedure SetTimeCount;
  Procedure MiseEnRepos;
  End;

Const
 EndCode:Byte=1;

{ objet TKmenuItem }
{ objet contenant les données relatives à un choix du menu }

Constructor TKMenuItem.Init(T:String);
Begin
 TStrTab.Init(4,4);
 Titre:=T;
End;

Procedure TKMenuItem.FaireFichierBatch;
Var f:Text;
    S:String;
    i:Integer;
Begin
 assign(f,NomFichierBatch);
 {$I-}
 rewrite(f);
 {$I+}
 if IOResult<>0
    then begin
          Message(' Erreur pendant la création du fichier BAT. ');
          exit;
         end;
 For i:=1 to NombreItems do
  begin
   S:=Ligne(i);
   writeln(f,S);
  end;
 close(f);
End;

Function TKMenuItem.IsNewMenu:Boolean;
Var S:String;
    i:Byte;
Begin
 S:=Ligne(1);
 For i:=1 to length(S) do
  S[i]:=upcase(S[i]);
 if copy(S,1,5)='KMENU'
    then IsNewMenu:=true
    else IsNewMenu:=false;
End;

Function TKMenuItem.GetNewMenu:TStr12;
Var S:String;
Begin
 S:=Ligne(1);
 while S[length(S)]=' ' do dec(S[0]);
 GetNewMenu:=copy(S,7,length(S)-6);
End;

{ objet TKMenuTab }
{ tableau de pointeurs sur des tableaux de caractères }

Constructor TKMenuTab.Init;
Begin
 TTabPtr.Init(20,5);
End;

Procedure TKMenuTab.Effacer(p:Pointer);
Var W:PKMenuItem;
Begin
 W:=PKMenuItem(p);
 if W<>nil
    then dispose(W,done);
End;

Function TKMenuTab.DonneTitre(n:Integer):String;
Var W:PKMenuItem;
    S:String;
Begin
 W:=DonneItem(n);
 if W=nil
    then S:=''
    else S:=W^.Titre;
 DonneTitre:=S;
End;

Function TKMenuTab.DonneItem(n:Integer):PKMenuItem;
Var W:PKMenuItem;
Begin
 if (n<1) or (n>NombreItems)
    then W:=nil
    else Lire(W,n);
 DonneItem:=W;
End;

{ objet TKMenuWin }

Constructor TKMenuWin.Init(NomFichier:PathStr);
Begin
 TWindow.Init(3,2,72,22,'');
 Ident:='KMENU';
 Items.Init;
 LireDatas(NomFichier);
 Choix:=0;
End;

Destructor TKMenuWin.Done;
Begin
 Items.Done;
 TWindow.Done;
End;

Function TKMenuWin.Ligne(n:Integer):String;
Var S:String;
    W:PKMenuItem;
Begin
 if (n<1) or (n>NombreItems)
    then S:=''
    else S:=Items.DonneTitre(n);
 S:='['+chr(ord('A')+n-1)+'] '+S;
 Ajuste(S,35);
 Ligne:=S;
End;

Procedure TKMenuWin.DrawInterior;
Var x,y:Byte;
    i:Integer;
    S,V:String;
Begin
 V:=' ';
 Ajuste(V,35);
 x:=1;
 y:=1;
 for i:=1 to 10 do
  begin
   Ecrire(V,x,y,0);
   inc(y);
   S:=Ligne(i);
   Ecrire(S,x,y,0);
   inc(y);
  end;
 x:=36;
 y:=1;
 for i:=11 to 20 do
  begin
   Ecrire(V,x,y,0);
   inc(y);
   S:=Ligne(i);
   Ecrire(S,x,y,0);
   inc(y);
  end;
End;

Function TKMenuWin.NumeroChoisi(P:TPoint):Integer;
Begin
 NumeroChoisi:=0;
 case P.X of
  1..3:
   if P.Y mod 2 =0
      then NumeroChoisi:=P.Y div 2;
  36..38:
   if P.Y mod 2 =0
      then NumeroChoisi:=10+P.Y div 2;
  end;
End;

Procedure TKMenuWin.HandleEvent(Var Event:TEvent);
Var P:TPoint;
    n:Integer;
Begin
 if Event.What=evKeyDown
    then if Event.KeyCode=Echap
            then begin
                  ExitCode:=exAnnule;
                  Event.What:=evNothing;
                  exit;
                 end;
 if Event.What=evMouseRDown
    then begin
          ExitCode:=exAnnule;
          Event.What:=exAnnule;
          exit;
         end;
 TWindow.HandleEvent(Event);
 case Event.What of
  evKeyDown:
   case Event.KeyCode of
    ord('A')..ord('T'):
     begin
      Choix:=Event.KeyCode-ord('A')+1;
      ExitCode:=exOk;
     end;
    ord('a')..ord('t'):
     begin
      Choix:=Event.KeyCode-ord('a')+1;
      ExitCode:=exOk;
     end;
    else exit;
    end;
  evMouseLDown:
   begin
    repeat
     GetMouseEvent(Event);
    until Event.What=evMouseLUp;
    MakeLocal(Event.Where,P);
    P.X:=P.X-Origin.X;
    P.Y:=P.Y-Origin.Y;
    n:=NumeroChoisi(P);
    if n<>0
       then begin
             Choix:=n;
             ExitCode:=exOk;
            end
       else exit;
   end;
  else exit;
  end;
 Event.What:=evNothing;
End;

Function TKMenuWin.NombreItems:Integer;
Begin
 NombreItems:=Items.NombreItems;
End;

Procedure TKMenuWin.LireDatas(NomFichier:PathStr);
Var f:Text;
    S:String;
    Tst:String[3];
    W:PKMenuItem;
    ErrNum:Word;
Begin
 ErrNum:=0;
 Assign(f,NomFichier);
 {$I-}
 Reset(f);
 {$I+}
 if IOResult<>0
    then begin
          Message(' Pas de fichier de données !!! ');
          ErrorFlag:=3;
          Exit;
         end;
 {$I-}
 ReadLn(f,Titre);
 W:=nil;
 while not EOF(f) and (ErrNum=0) do
  begin
   Readln(f,S);
   ErrNum:=IOResult;
   if copy(S,1,7)='Palette'
      then begin
            PalOffset:=3*(ord(S[9])-ord('1'))+1;
            Readln(f,S);
           end;
   Tst:=copy(S,1,3);
   if Tst='***'
      then begin
            if W<>nil
               then begin
                     Items.Ajouter(W);
                     W:=nil;
                    end;
            if ErrNum=0
               then begin
                     Readln(f,S);
                     ErrNum:=IOResult;
                     if (ErrNum=0) and (S<>'')
                        then begin
                              while S[length(S)]=' '
                               do dec(S[0]);
                              W:=new(PKMenuItem,Init(S));
                             end;
                    end;
           end
      else begin
            if W<>nil
               then W^.AjouterLigne(S);
           end;
  end;
 Close(f);
 {$I+}
End;

Procedure TKmenuWin.SauverDatas(NomFichier:PathStr);
Var f:Text;
    S:String;
    W:PKMenuItem;
    i,j:Integer;
Begin
 Assign(f,NomFichier);
 {$I-}
 Rewrite(f);
 {$I+}
 if IOResult<>0
    then begin
          Message(' Création de fichier impossible !!! ');
          ErrorFlag:=3;
          Exit;
         end;
 { titre }
 Writeln(f,Titre);
 { palette de la fenêtre }
 i:=PalOffSet div 3 +1;
 str(i,S);
 Writeln(f,S);
 { choix }
 For i:=1 to Items.NombreItems do
  begin
   Str(i,S);
   S:='***Choix '+S+'***';
   writeln(f,S);
   W:=Items.DonneItem(i);
   writeln(f,W^.Titre);
   for j:=1 to W^.NombreItems do
    writeln(f,W^.Ligne(j));
  end;
 Writeln(f,'***Fin du fichier***');
 Close(f);
End;

{ objet TKMenuApp }

Constructor TKMenuApp.Init;
Var i:Byte;
Begin
 TTextApp.Init;
 SetTimeCount;
 if paramcount>0
    then begin
          MotDePasse:=paramstr(1);
          for i:=1 to length(MotDePasse)
           do MotDePasse[i]:=upcase(MotDePasse[i]);
          SetCommand(cmPassWord);
         end
    else MotDePasse:='';
 LireNiveau;
 if MotDePasse=''
    then SetCommand(cmKMenu);
End;

Procedure TKMenuApp.LireNiveau;
Var f:Text;
    S:String;
Begin
 { recherche du fichier de données actuel }
 Niveau:=0;
 assign(f,'KMENU.CFG');
 {$I-}
 reset(f);
 {$I+}
 if IOResult<>0
    then begin
          Titre:='KMENU 2.1  (K.B. 1994)';
          Niveau:=1;
          TabNiv[Niveau]:='KMENU.DAT';
          EcrireNiveau;
         end
    else begin
          readln(f,Titre);
          while not EOF(f) do
           begin
            readln(f,S);
            if S<>''
               then begin
                     inc(Niveau);
                     TabNiv[Niveau]:=S;
                    end;
           end;
          close(f);
         end;
End;

Procedure TKMenuApp.EcrireNiveau;
Var f:Text;
    i:Byte;
Begin
 assign(f,'KMENU.CFG');
 rewrite(f);
 writeln(f,Titre);
 For i:=1 to Niveau do
  writeln(f,TabNiv[i]);
 close(f);
End;

Procedure TKMenuApp.HandleEvent(Var Event:TEvent);
Var W      : PKMenuWin;
    CurWin : PGenView;
Begin
 if (Event.What=evCommand) and (Event.Command=cmQuit) and (EndCode=1)
    then if not ConfirmExit
            then begin
                  Event.What:=evNothing;
                  exit;
                 end;
 TTextApp.HandleEvent(Event);
 CurWin:=FindSelect;
 if (CurWin<>nil) and (CurWin^.Ident='KMENU') and (CurWin^.ExitCode<>0)
    then begin
          ChangeWin;
          exit;
         end;
 case Event.What of
  evCommand:
   case Event.Command of
    cmAbout: begin
              Message(chr(13)+
                      '      KMENU 2.1       '+chr(13)+
                      '   Kostrzewa Bruno    '+chr(13)+
                      '    novembre 1994     '+chr(13));
             end;
    cmKMenu: begin
              Patience('Chargement du menu en cours...');
              W:=new(PKMenuWin,Init(TabNiv[Niveau]));
              FinPatience;
              if W^.IsValid
                 then begin
                       if CurWin<>nil
                          then dispose(CurWin,Done);
                       Insert(W);
                       W^.Show;
                      end
                 else begin
                       dispose(W,Done);
                       if Niveau>1
                          then begin
                                dec(Niveau);
                                EcrireNiveau;
                                SetCommand(cmKMenu);
                               end
                          else begin
                                Message(' Fin du programme. ');
                                EndCode:=2;
                                SetCommand(cmQuit);
                               end;
                       end;
              end;
     cmRepos: MiseEnRepos;
     cmPassWord:
      if PassWord(MotDePasse)
         then SetCommand(cmKMenu)
         else begin
               EndCode:=2;
               SetCommand(cmQuit);
              end;
    else exit;
   end;
  evKeyDown:
   case Event.KeyCode of
    {F2: if (Curwin<>nil) and (CurWin^.Ident=nKMenuWin)
           then begin
                 Patience('Sauvegarde du menu en cours...');
                 W:=PKMenuWin(CurWin);
                 W^.SauverDatas(TabNiv[Niveau]);
                 FinPatience;
                end;}
    F7: SetCommand(cmRepos);
    F9: SetCommand(cmAbout);
    else exit;
   end;
 end;
 SetTimeCount;
 Event.What:=evNothing;
End;

Procedure TKMenuApp.SetTimeCount;
Var h,m,s,c : Word;
Begin
 GetTime(h,m,s,c);
 TimeCount:=3600*h+60*m+s;
End;

Procedure TKMenuApp.TempsMort;
Var h,m,s,c : Word;
    tmp     : LongInt;
Begin
 TTextApp.TempsMort;
 GetTime(h,m,s,c);
 tmp:=3600*h+60*m+s;
 if tmp-TimeCount>=DelaiRepos
    then MiseEnRepos;
End;

Procedure TKMenuApp.MiseEnRepos;
Var E : TEvent;
Begin
 MouseHide;
 SetActivePage(1);
 FillScreen(32+256*7);
 repeat
  ReadEvent(E);
 until E.What<>evNothing;
 SetActivePage(0);
 MouseShow;
 SetTimeCount;
End;

Procedure TKMenuApp.ChangeWin;
Var CW : PKMenuWin;
    W  : PKMenuItem;
Begin
 CW:=PKMenuWin(FindSelect);
 if CW^.Choix<>0
    then begin
          W:=CW^.Items.DonneItem(CW^.Choix);
          if not W^.IsNewMenu
             then begin
                   Patience('Création du fichier Batch...');
                   W^.FaireFichierBatch;
                   FinPatience;
                   EndCode:=0;
                   SetCommand(cmQuit);
                   end
             else begin
                   if Niveau<nbrNiv
                      then begin
                            inc(Niveau);
                            TabNiv[Niveau]:=W^.GetNewMenu;
                            EcrireNiveau;
                            SetCommand(cmKMenu);
                           end;
                  end;
         end
    else begin
          if Niveau>1
             then begin
                   dec(Niveau);
                   EcrireNiveau;
                   SetCommand(cmKMenu);
                  end
             else begin
                   if ConfirmExit
                      then begin
                            SetCommand(cmQuit);
                            EndCode:=2;
                           end
                  end;
         end;
 CW^.ExitCode:=0;
End;

Function TKMenuApp.TestPassWord:Boolean;
Begin
 if MotDePasse=''
    then TestPassWord:=true
    else TestPassWord:=PassWord(MotDePasse);
End;

Function TKMenuApp.ConfirmExit:Boolean;
Var S:String;
    i:Byte;
Begin
 WinRead(S,' Quitter ? ');
 if S<>''
    then for i:=1 to length(S) do
          S[i]:=upcase(S[i]);
 if S='OUI'
    then ConfirmExit:=true
    else ConfirmExit:=false;
End;

{---------------------------------------------------------------------------}

Var MonApp:PKMenuApp;

BEGIN
{$IFDEF DEBUG}
 InitMem;
{$ENDIF}
 QuitMsg:='';
 MonApp:=New(PKMenuApp,Init);
 MonApp^.Exec;
 dispose(MonApp,Done);
{$IFDEF DEBUG}
 diagmem;
{$ENDIF}
 halt(EndCode);
END.

{                         Fin du Fichier KMenu2.Pas                         }