home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1988 / 02 / hyperkey / hyperkey.utl < prev    next >
Encoding:
Text File  |  1987-11-22  |  6.0 KB  |  130 lines
  1. (* ------------------------------------------------------------------------- *)
  2. (*                                HYPERKEY.UTL                               *)
  3. (*                Diverse in HYPERKEY benoetigte Utility-Routinen            *)
  4. (* ------------------------------------------------------------------------- *)
  5. (*       String ins HYPERKEY-Fenster schreiben (direkt ins Video-RAM):       *)
  6. PROCEDURE WriteString (XPos,YPos: BYTE; s: StringType);
  7.    VAR Count :BYTE;  Offset,Attr :INTEGER;
  8.        VideoAttribute :BYTE ABSOLUTE DSeg:$0008;
  9. BEGIN
  10.    Offset := Pred(XPos+XWin) SHL 1 + 160 * Pred(YPos+YWin);
  11.    Attr :=  VideoAttribute SHL 8;
  12.    FOR Count := 1 TO Length(s) DO BEGIN
  13.       MemW [VideoBuffer:Offset] := Attr + Ord(s[Count]);
  14.       Offset := Succ(Succ(Offset))
  15.    END
  16. END;
  17. (*                      Cursor im Arbeitsfenster positionieren:              *)
  18. PROCEDURE SetCursor (XPos,YPos: BYTE);
  19. BEGIN  GotoXY (XWin+XPos, YWin+YPos)   END;
  20. (*                          Cursorgroesse veraendern:                        *)
  21. PROCEDURE CursorShape (Shape :ShapeType);
  22.    VAR   Regs :Regs8088_;   EGA :BOOLEAN;
  23.    CONST Mask :ARRAY [0..1,ShapeType] OF INTEGER = (($0007,$0407,$0607),
  24.                                                     ($000D,$070D,$0C0D));
  25. BEGIN
  26.    WITH Regs DO BEGIN
  27.       AH := $11;  AL := $30;  BL := $00;  CX := $FFFF;  Intr (Video, Regs);
  28.       EGA := (CX <> $FFFF);         (* ist der Grafikadapter eine EGA-Karte? *)
  29.       AH := $01;  CX := Mask [Ord(ScreenMode=Monochrom) + Ord(EGA), Shape];
  30.       Intr (Video, Regs)
  31.    END
  32. END;
  33. (*          Cursor an/ausschalten, Cursorgroesse bleibt unveraendert:        *)
  34. PROCEDURE Cursor (Mode :CursorMode);
  35.    VAR Regs :Regs8088_;
  36. BEGIN
  37.    WITH Regs DO BEGIN
  38.       AH := $03;  Intr (Video, Regs);          (* Cursor-Informationen holen *)
  39.       CASE Mode OF
  40.          on : CH := CH AND $EF;                            (* Bit 7 loeschen *)
  41.          off: CH := CH  OR $10                               (* Bit 7 setzen *)
  42.       END;
  43.       AH := $01;  Intr (Video, Regs)       (* Cursorform wieder wegschreiben *)
  44.    END
  45. END;
  46. (*                  liefert Leerzeichen-String der Laenge "n":               *)
  47. FUNCTION Space (n :BYTE) :StringType;
  48.    VAR s :StringType;
  49. BEGIN  FillChar (s[1], n, 32);  s[0] := Chr (n);  Space := s   END;
  50. (*  liefert "Number" rechtsbuendig als String in einem "Width" breiten Feld: *)
  51. FUNCTION NumStr (Number :INTEGER; Width :BYTE) :StringType;
  52.    VAR s :StringType;
  53. BEGIN   Str (Number:Width,s);  NumStr := s   END;
  54. (*                        neue Farbkombination bestimmen:                    *)
  55. PROCEDURE SetColors (Pen, Paper :INTEGER);
  56. BEGIN   TextColor (Pen);  TextBackGround (Paper)   END;
  57. (*                           Ist ScrollLock aktiv?                           *)
  58. FUNCTION ScrollLock :BOOLEAN;
  59.    VAR Regs :Regs8088_;
  60. BEGIN
  61.    WITH Regs DO BEGIN
  62.       AH := $02;  Intr (Old_Kbd, Regs);                (* Shift-Status holen *)
  63.       ScrollLock := AL AND $10 <> 0                        (* Bit 4 gesetzt? *)
  64.    END
  65. END;
  66. (*                   Tastatur auf internen Code abfragen:                    *)
  67. PROCEDURE GetKey (VAR Key :INTEGER);
  68.    VAR Regs :Regs8088_;
  69. BEGIN
  70.    SetColors (FrameColor, WindowBack);
  71.    WITH Regs DO BEGIN
  72.       REPEAT
  73.          IF ScrollLock THEN WriteString (2,1,'S')
  74.          ELSE WriteString (2,1,' ');
  75.          AH := $01;  Intr (Old_Kbd, Regs);        (* Puffer-Zustand abfragen *)
  76.       UNTIL Flags AND $40 = 0;                       (* bis Zeichen vorliegt *)
  77.       AH := $00;  Intr (Old_Kbd, Regs);  Key := AX        (* Zeichen abholen *)
  78.    END
  79. END;
  80. (*  belegt die durch KeyCode charakterisierte Taste mit dem String "Macro":  *)
  81. PROCEDURE SetKey (KeyCode :INTEGER; Macro :StringType);
  82.    CONST LeadIn = ^['[';                         (* ANSI-Einleitungs-Sequenz *)
  83.    VAR CodeStr :STRING[6];  Regs :Regs8088_;
  84. BEGIN
  85.    IF Length(Macro) > 0 THEN BEGIN
  86.       IF Lo(KeyCode) = 0 THEN BEGIN                     (* erweiterter Code? *)
  87.          Str (Hi(KeyCode), CodeStr);  CodeStr := '0;' + CodeStr
  88.       END
  89.       ELSE  Str (KeyCode, CodeStr);
  90.       Macro := Concat (LeadIn, CodeStr, ';"', Macro, '"p$');
  91.       WITH Regs DO BEGIN
  92.          AH := $09;  DS := Seg (Macro);  DX := Succ (Ofs(Macro));
  93.          MsDos (Regs)                            (* String ueber DOS an ANSI *)
  94.       END
  95.    END
  96. END;
  97. (*                Umrechnung eines Dezimalbytes nach Hexadezimal:            *)
  98. FUNCTION HexByte (b :BYTE) :StringType;
  99.    CONST HexDigit :ARRAY [0..15] OF CHAR = '0123456789ABCDEF';
  100. BEGIN   HexByte := HexDigit[b SHR 4] + HexDigit[b AND $0F]   END;
  101. (*               Umrechnung einer Dezimaladresse nach Hexadezimal:           *)
  102. FUNCTION HexWord (w :INTEGER) :StringType;
  103. BEGIN   HexWord := HexByte (w SHR 8) + HexByte (w AND $FF)   END;
  104. (*          gibt die Zeichenkette "s" in der HYPERKEY-Menuezeile aus:        *)
  105. PROCEDURE MenuLine (s :StringType);
  106. BEGIN
  107.    SetColors (MenuFore, MenuBack);   WriteString (1, 12, Space(64));
  108.    WriteString (5, 12, s);           SetCursor (5+Length(s), 12)
  109. END;
  110. (*                  Ausgabe einer Fehlermeldung in der Menuezeile:           *)
  111. PROCEDURE ErrorMsg (ErrorNr :BYTE);
  112.    CONST Msg :ARRAY [1..5] OF STRING[52] = (
  113.                'Nicht mehr genuegend Speicherplatz vorhanden!',
  114.                'Taste ist schon belegt, bitte andere Taste waehlen!',
  115.                'HYPERKEY-Aktivierungstaste darf nicht belegt werden!',
  116.                'Datei befindet sich nicht im aktuellen Verzeichnis!',
  117.                'Datei existiert bereits, ueberschreiben (J/N) ? ');
  118.    VAR i :BYTE;
  119. BEGIN
  120.    MenuLine (Msg[ErrorNr]);
  121.    FOR i:=1 TO 3 DO BEGIN
  122.       Sound ( 600); Delay (40);  Sound ( 400); Delay (40);
  123.       Sound (1000); Delay (40);  Sound ( 400); Delay (40);
  124.       Sound (1200); Delay (40);  NoSound; Delay (5)
  125.    END;
  126.    Delay (300)
  127. END;
  128. (* ------------------------------------------------------------------------- *)
  129. (*                                HYPERKEY.UTL                               *)
  130.