home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1990 / 11 / tricks / maketab.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-08-06  |  4.5 KB  |  173 lines
  1. (* ------------------------------------------------------ *)
  2. (*                     MAKETAB.PAS                        *)
  3. (*      Dieses Programm erzeugt die Austauschtabelle      *)
  4. (*         (c) 1990 Oliver Hallmann & TOOLBOX             *)
  5. (* ------------------------------------------------------ *)
  6. PROGRAM MakeTab;
  7.  
  8. USES Crt;
  9.  
  10. TYPE
  11.   str10   = STRING [10];
  12.   tab_typ = ARRAY [0..255] OF str10;
  13.  
  14. VAR
  15.   tab : tab_typ;
  16.   d   : FILE OF tab_typ;
  17.  
  18.   PROCEDURE GetStr(VAR s : str10);
  19.   VAR
  20.     c    : CHAR;
  21.     scan : BOOLEAN;
  22.     x    : BYTE;
  23.   BEGIN
  24.     ClrScr;
  25.     GotoXY(1,2);
  26.     WriteLn('Geben Sie bitten den String ein. ',
  27.             'Sonderzeichen erreichen Sie, indem');
  28.     WriteLn('Sie die ALT-Taste drücken und den ',
  29.             'ASCII-Code eingeben. Maximal 10 Zeichen.');
  30.     Write  ('Ende mit F10. Löschen mit F5. #0 mit F1! ',
  31.             'ASCII-Nr. des letzten Zeichens: ');
  32.     s := '';
  33.    REPEAT
  34.      GotoXY(75,4);
  35.      IF Length(s) > 0 THEN
  36.        Write(Ord(s[Length(s)]):3)
  37.      ELSE
  38.        Write('---');
  39.      GotoXY(35,6);  ClrEOL;  NormVideo;
  40.      FOR x := 1 TO Length(s) DO
  41.        IF s[x] IN [#0..#31, #255] THEN BEGIN
  42.          HighVideo;
  43.          Write('@');
  44.          NormVideo;
  45.        END ELSE
  46.          Write(s[x]);
  47.      REPEAT
  48.        c := ReadKey;
  49.        IF c = #0 THEN BEGIN
  50.          c    := ReadKey;
  51.          scan := TRUE
  52.        END ELSE
  53.          scan := FALSE;
  54.       UNTIL (NOT scan) OR
  55.             (scan AND (c IN [#59, #63, #68]));
  56.       IF (scan) AND (c = #63) AND (Length(s) > 0) THEN
  57.         Delete(s, Length(s), 1);
  58.       IF (NOT scan) AND (Length(s) < 10) THEN
  59.          s := s + c;
  60.       IF (scan) AND (c = #59) AND (LENGTH(s) < 10) THEN
  61.          s := s + #0;
  62.     UNTIL (scan) AND (c = #68);
  63.   END;
  64.  
  65.   PROCEDURE SaveTab;
  66.   VAR
  67.     io : INTEGER;
  68.   BEGIN
  69.     Assign(d, 'HPRINT.TAB');
  70.     {$I-}
  71.     REWRITE(d);
  72.     io := IOResult;
  73.     {$I+}
  74.     IF io <> 0 THEN BEGIN
  75.       HighVideo;
  76.       WriteLn('Diskette schreibgeschützt, ',
  77.               'Programm wird abgebrochen!');
  78.       NormVideo;
  79.       Halt(2);
  80.     END ELSE BEGIN
  81.       Write(d, tab);
  82.       Close(d);
  83.     END;
  84.   END;
  85.  
  86.   PROCEDURE LoadTab;
  87.   VAR
  88.     io : INTEGER;
  89.     x  : BYTE;
  90.   BEGIN
  91.     ASSIGN(d, 'HPRINT.TAB');
  92.     {$I-}
  93.     Reset(d);
  94.     io := IOResult;
  95.     {$I+}
  96.     IF io <> 0 THEN BEGIN
  97.       FOR x := 0 TO 255 DO tab[x] := CHAR(x);
  98.       SaveTab;
  99.     END ELSE BEGIN
  100.       Read(d,tab);
  101.       Close(d);
  102.     END;
  103.   END;
  104.  
  105.   PROCEDURE Eingabe;
  106.   VAR
  107.     x   : INTEGER;
  108.     c   : CHAR;
  109.     nr  : STRING[3];
  110.     err : INTEGER;
  111.     a   : BYTE;
  112.   BEGIN
  113.     LoadTab;
  114.     REPEAT
  115.       ClrScr;
  116.       WriteLn;
  117.       WriteLn(' 1 : Tabelle löschen');
  118.       WriteLn(' 2 : Zeichen austauschen');
  119.       WriteLn(' 0 : Zurück zum Hauptmenü');
  120.       WriteLn;
  121.       Write  ('Ihre Wahl? ');
  122.       REPEAT
  123.         c := ReadKey;
  124.       UNTIL c IN ['1', '2', '0'];
  125.       Write(c);
  126.       CASE c OF
  127.         '1' : BEGIN
  128.                 GotoXY(1,7); Write('Wirklich [J/N]? ');
  129.                 REPEAT
  130.                   c := UpCase(ReadKey);
  131.                 UNTIL c IN ['J', 'N'];
  132.                 GotoXY(1,7);  ClrEOL;
  133.                 IF c = 'J' THEN
  134.                   FOR x := 0 TO 255 DO tab[x] := CHAR(x);
  135.               END;
  136.         '2' : BEGIN
  137.                 REPEAT
  138.                   GotoXY(1,7); ClrEOL;
  139.                   Write('Welches Zeichen? ');
  140.                   ReadLN(nr);
  141.                   VAL(nr, x, err);
  142.                 UNTIL (err = 0) AND (x IN [0..255]);
  143.                 GotoXY(1,7);  ClrEOL;
  144.                 FOR a:=1 TO Length(tab[x]) DO
  145.                   IF tab[x][a] IN [#0..#31, #255] THEN BEGIN
  146.                     HighVideo;
  147.                     Write('@');
  148.                     NormVideo;
  149.                   END ELSE
  150.                     Write(tab[x][a]);
  151.                 WriteLn;
  152.                 ClrEOL;
  153.                 WriteLn('^^^^^^^^^^ ASCII-Nr.: ', x);
  154.                 ClrEOL;
  155.                 WRITE('Diesen String löschen [J/N]?');
  156.                 REPEAT
  157.                   c := UpCase(ReadKey);
  158.                 UNTIL c IN ['J', 'N'];
  159.                 GotoXY(1,8);  ClrEOL;
  160.                 GotoXY(1,9);  ClrEOL;
  161.                 GotoXY(1,7);  ClrEOL;
  162.                 IF c = 'J' THEN GetStr(tab[x]);
  163.               END;
  164.       END;
  165.     UNTIL c = '0';
  166.     SaveTab;
  167.   END;
  168.  
  169. BEGIN
  170.   Eingabe;
  171. END.
  172. (* ------------------------------------------------------ *)
  173. (*                Ende von MAKETAB.PAS                    *)