home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1989 / 11 / tricks / readkey.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-08-11  |  4.6 KB  |  130 lines
  1. (* ------------------------------------------------------ *)
  2. (*                 READKEY.PAS                            *)
  3. (*        (c) 1989 by Hagen Lehmann & TOOLBOX             *)
  4. (* ------------------------------------------------------ *)
  5. {$R-,S-,I-,D-,F-,V-,B-,N-,L-}
  6. {$M 1024,0,0}
  7.  
  8. USES Crt, Dos;
  9. CONST
  10.   ErrorLevelFunc      = $4C;
  11.   DosInterrupt        = $21;
  12.   Attribute           : ARRAY [1..6] Of STRING[17]
  13.                           = ('HELL',
  14.                              'HELLUNTERSTRICHEN',
  15.                              'INVERS',
  16.                              'NORMAL',
  17.                              'SCHWARZ',
  18.                              'UNTERSTRICHEN');
  19.   AttrWerte           : ARRAY [1..6] OF BYTE
  20.                             = (15, 9, 120, 7, 0, 1);
  21.  
  22. VAR
  23.   Taste               : CHAR;
  24.   Regs                : Registers;
  25.   Farbe, Text, Tasten : STRING;
  26.   Loop, Position      : BYTE;
  27.   AktivesAttr,
  28.   ErwFarbe            : WORD;
  29.   Fehler              : INTEGER;
  30.   FestFarbe           : BOOLEAN;
  31.  
  32.   FUNCTION UpString(Quelle : STRING) : STRING;
  33.   BEGIN
  34.     FOR Loop := 1 TO Length(Quelle) DO
  35.       Quelle[Loop] := UpCase(Quelle[Loop]);
  36.     UpString := Quelle;
  37.   END;
  38.  
  39.   PROCEDURE SetErrorLevel(FehlerCode : BYTE);
  40.   BEGIN
  41.     WITH Regs DO BEGIN
  42.       ah := ErrorLevelFunc;           { Funktion auswählen }
  43.       al := FehlerCode;             { Wert des Errorlevels }
  44.       Intr(DosInterrupt, Regs);              { Wert setzen }
  45.     END;
  46.   END;
  47.  
  48. BEGIN
  49.   AktivesAttr := TextAttr;
  50.   IF (ParamStr(1) = '?') OR (ParamCount = 0) THEN BEGIN
  51.     ClrScr;
  52.     WriteLn;
  53.     WriteLn('Aufruf : READKEY [["Text", Tasten [Farbe]]] ');
  54.     WriteLn;
  55.     WriteLn(' Mögliche Farben :');
  56.     Writeln('  Hell, Hellunterstrichen, Invers, Normal, ',
  57.             'Schwarz, Unterstrichen');
  58.     Writeln;
  59.     Writeln(' Beispiel :');
  60.     Writeln('   readkey "_Drücken_Sie_[J]a_oder_[N]ein_",',
  61.             'jn invers');
  62.     Writeln('       (`_` steht für Leerzeichen)');
  63.     Writeln('   readkey "_Laufwerk_[A]:_oder_[C]:_?_",',
  64.             'ac 141');
  65.     Writeln('       (141 ist ein erweitertes Attribut)');
  66.     Halt;
  67.   END;
  68.  
  69.   Farbe     := UpString(ParamStr(2));  { Farbe übernehmen }
  70.   FestFarbe := FALSE;
  71.   IF Length(Farbe) > 0 THEN     { ist eine Farbe gegeben? }
  72.     FOR Loop := 1 TO 6 DO       { ja, welche der 6 Farben }
  73.       IF Farbe = Attribute[Loop] THEN BEGIN
  74.         TextAttr  := AttrWerte[Loop];
  75.         Loop      := 6;
  76.         FestFarbe := TRUE;
  77.       END;
  78.     IF NOT FestFarbe THEN BEGIN
  79.                         { ist es keine vorgegebene Farbe? }
  80.       Val(Farbe, ErwFarbe, Fehler);
  81.               { ja, erweiterte Farbe in Zahl konvertieren }
  82.       IF Fehler = 0 THEN           { ist Farbe eine Zahl? }
  83.         TextAttr := ErwFarbe;
  84.                             { ja, erweiterte Farbe setzen }
  85.     END;
  86.  
  87.     Text     := ParamStr(1);            { Text übernehmen }
  88.     Tasten   := UpString(Text);       { Tasten übernehmen }
  89.     Position := Pos('",', Text);{ (Position der Tasten)-2 }
  90.  
  91.     IF (Text[1] = '"') AND ((Position > 1) OR
  92.                        (Text[Length(Text)]='"')) THEN BEGIN
  93.       Delete(Text, 1, 1);          { Gänsefüßchen löschen }
  94.       IF Position > 1 THEN
  95.         Delete(Text, Position-1, Length(Text)-Position+2)
  96.       ELSE
  97.         Delete(Text, Length(Text), 1);
  98.       FOR Loop := 1 TO Length(Text) DO
  99.         IF Text[Loop] = '_' THEN Text[Loop] := ' ';
  100.                                      { Leerzeichen setzen }
  101.       IF Position > 1 THEN
  102.         Delete(Tasten, 1, Position+1)
  103.                                    { Tasten herausfiltern }
  104.       ELSE
  105.         Tasten := '';
  106.       Write(Text);                       { Text schreiben }
  107.       IF Tasten <> '' THEN BEGIN
  108.                              { Abfrage mit Tastenvorgaben }
  109.         REPEAT
  110.           Taste := UpCase(ReadKey);      { Taste einlesen }
  111.         UNTIL Pos(Taste, Tasten) > 0;
  112.                      { Position der Taste in allen Tasten }
  113.         TextAttr := AktivesAttr;
  114.                               { Attribut wiederherstellen }
  115.         Writeln;                         { Zeilenvorschub }
  116.         SetErrorLevel(Pos(Taste, Tasten));
  117.                                   { Errorlevel = Position }
  118.       END ELSE BEGIN
  119.                             { Abfrage ohne Tastenvorgaben }
  120.         Taste    := UpCase(ReadKey);
  121.         TextAttr := AktivesAttr;
  122.         Writeln;
  123.         SetErrorLevel(Ord(Taste));
  124.                         { Errorlevel = Scancode der Taste }
  125.       END;
  126.   END;
  127. END.
  128. (* ------------------------------------------------------ *)
  129. (*               Ende von READKEY.PAS                     *)
  130.