Использовать модуль CRT в Delphi

Оформил: DeeCo

{$IfDef VER130}
   {$Define NEW_STYLES}
 {$EndIf}
 {$IfDef VER140}
   {$Define NEW_STYLES}
 {$EndIf}

 {..$Define HARD_CRT}      {Redirect STD_...}
 {..$Define CRT_EVENT}     {CTRL-C,...}
 {$Define MOUSE_IS_USED}   {Handle mouse or not}
 {..$Define OneByOne}      {Block or byte style write}
 unit CRT32;

 Interface
   {$IfDef Win32}
   Const
     { CRT modes of original CRT unit }
     BW40 = 0;     { 40x25 B/W on Color Adapter }
     CO40 = 1;     { 40x25 Color on Color Adapter }
     BW80 = 2;     { 80x25 B/W on Color Adapter }
     CO80 = 3;     { 80x25 Color on Color Adapter }
     Mono = 7;     { 80x25 on Monochrome Adapter }
     Font8x8 = 256;{ Add-in for ROM font }
     { Mode constants for 3.0 compatibility of original CRT unit }
     C40 = CO40;
     C80 = CO80;
     { Foreground and background color constants of original CRT unit }
     Black = 0;
     Blue = 1;
     Green = 2;
     Cyan = 3;
     Red = 4;
     Magenta = 5;
     Brown  6;
     LightGray = 7;
     { Foreground color constants of original CRT unit }
     DarkGray = 8;
     LightBlue = 9;
     LightGreen = 10;
     LightCyan = 11;
     LightRed = 12;
     LightMagenta = 13;
     Yellow = 14;
     White = 15;
     { Add-in for blinking of original CRT unit }
     Blink = 128;
     {  }
     {  New constans there are not in original CRT unit }
     {  }
     MouseLeftButton = 1;
     MouseRightButton = 2;
     MouseCenterButton = 4;

 var
   { Interface variables of original CRT unit }
   CheckBreak: Boolean;    { Enable Ctrl-Break }
   CheckEOF: Boolean;      { Enable Ctrl-Z }
   DirectVideo: Boolean;   { Enable direct video addressing }
   CheckSnow: Boolean;     { Enable snow filtering }
   LastMode: Word;         { Current text mode }
   TextAttr: Byte;         { Current text attribute }
   WindMin: Word;          { Window upper left coordinates }
   WindMax: Word;          { Window lower right coordinates }
   {  }
   {  New variables there are not in original CRT unit }
   {  }
   MouseInstalled: boolean;
   MousePressedButtons: word;

 { Interface functions & procedures of original CRT unit }
 procedure AssignCrt(var F: Text);
 function KeyPressed: Boolean;
 function ReadKey: char;
 procedure TextMode(Mode: Integer);
 procedure Window(X1, Y1, X2, Y2: Byte);
 procedure GotoXY(X, Y: Byte);
 function WhereX: Byte;
 function WhereY: Byte;
 procedure ClrScr;
 procedure ClrEol;
 procedure InsLine;
 procedure DelLine;
 procedure TextColor(Color: Byte);
 procedure TextBackground(Color: Byte);
 procedure LowVideo;
 procedure HighVideo;
 procedure NormVideo;
 procedure Delay(MS: Word);
 procedure Sound(Hz: Word);
 procedure NoSound;
 { New functions & procedures there are not in original CRT unit }
 procedure FillerScreen(FillChar: Char);
 procedure FlushInputBuffer;
 function GetCursor: Word;
 procedure SetCursor(NewCursor: Word);
 function MouseKeyPressed: Boolean;
 procedure MouseGotoXY(X, Y: Integer);
 function MouseWhereY: Integer;
 function MouseWhereX: Integer;
 procedure MouseShowCursor;
 procedure MouseHideCursor;
 { These functions & procedures are for inside use only }
 function MouseReset: Boolean;
 procedure WriteChrXY(X, Y: Byte; Chr: char);
 procedure WriteStrXY(X, Y: Byte; Str: PChar; dwSize: Integer);
 procedure OverwriteChrXY(X, Y: Byte; Chr: char);
 {$EndIf Win32}

 implementation
 {$IfDef Win32}

 uses Windows, SysUtils;

 type
   POpenText = ^TOpenText;
   TOpenText = function(var F: Text; Mode: Word): Integer; far;

 var
   IsWinNT: boolean;
   PtrOpenText: POpenText;
   hConsoleInput: THandle;
   hConsoleOutput: THandle;
   ConsoleScreenRect: TSmallRect;
   StartAttr: word;
   LastX, LastY: byte;
   SoundDuration: integer;
   SoundFrequency: integer;
   OldCP: integer;
   MouseRowWidth, MouseColWidth: word;
   MousePosX, MousePosY: smallInt;
   MouseButtonPressed: boolean;
   MouseEventTime: TDateTime;
 {  }
 {  This function handles the Write and WriteLn commands }
 {  }

 function TextOut(var F: Text): Integer; far;
   {$IfDef OneByOne}
 var
   dwSize: DWORD;
   {$EndIf}
 begin
   with TTExtRec(F) do
   begin
     if BufPos > 0 then
     begin
       LastX := WhereX;
       LastY := WhereY;
       {$IfDef OneByOne}
       dwSize := 0;
       while (dwSize < BufPos) do
       begin
         WriteChrXY(LastX, LastY, BufPtr[dwSize]);
         Inc(dwSize);
       end;
       {$Else}
       WriteStrXY(LastX, LastY, BufPtr, BufPos);
       FillChar(BufPtr^, BufPos + 1, #0);
       {$EndIf}
       BufPos := 0;
     end;
   end;
   Result := 0;
 end;
 {  }
 {  This function handles the exchanging of Input or Output }
 {  }

 function OpenText(var F: Text; Mode: Word): Integer; far;
 var
   OpenResult: integer;
 begin
   OpenResult := 102; { Text not assigned }
   if Assigned(PtrOpenText) then
   begin
     TTextRec(F).OpenFunc := PtrOpenText;
     OpenResult := PtrOpenText^(F, Mode);
     if OpenResult = 0 then
     begin
       if Mode = fmInput then
         hConsoleInput := TTextRec(F).Handle
       else
       begin
         hConsoleOutput := TTextRec(F).Handle;
         TTextRec(Output).InOutFunc := @TextOut;
         TTextRec(Output).FlushFunc := @TextOut;
       end;
     end;
   end;
   Result := OpenResult;
 end;
 {  }
 {  Fills the current window with special character }
 {  }

 procedure FillerScreen(FillChar: Char);
 var
   Coord: TCoord;
   dwSize, dwCount: DWORD;
   Y: integer;
 begin
   Coord.X := ConsoleScreenRect.Left;
   dwSize := ConsoleScreenRect.Right - ConsoleScreenRect.Left + 1;
   for Y := ConsoleScreenRect.Top to ConsoleScreenRect.Bottom do
   begin
     Coord.Y := Y;
     FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
     FillConsoleOutputCharacter(hConsoleOutput, FillChar, dwSize, Coord, dwCount);
   end;
   GotoXY(1,1);
 end;
 {  }
 {  Write one character at the X,Y position }
 {  }

 procedure WriteChrXY(X, Y: Byte; Chr: char);
 var
   Coord: TCoord;
   dwSize, dwCount: DWORD;
 begin
   LastX := X;
   LastY := Y;
   case Chr of
     #13: LastX := 1;
     #10:
       begin
         LastX := 1;
         Inc(LastY);
       end;
     else
       begin
         Coord.X := LastX - 1 + ConsoleScreenRect.Left;
         Coord.Y := LastY - 1 + ConsoleScreenRect.Top;
         dwSize := 1;
         FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
         FillConsoleOutputCharacter(hConsoleOutput, Chr, dwSize, Coord, dwCount);
         Inc(LastX);
       end;
   end;
   if (LastX + ConsoleScreenRect.Left) > (ConsoleScreenRect.Right + 1) then
   begin
     LastX := 1;
     Inc(LastY);
   end;
   if (LastY + ConsoleScreenRect.Top) > (ConsoleScreenRect.Bottom + 1) then
   begin
     Dec(LastY);
     GotoXY(1,1);
     DelLine;
   end;
   GotoXY(LastX, LastY);
 end;
 {  }
 {  Write string into the X,Y position }
 {  }
 (* !!! The WriteConsoleOutput does not write into the last line !!!
   Procedure WriteStrXY(X,Y: byte; Str: PChar; dwSize: integer );
   {$IfDef OneByOne}
     Var
       dwCount: integer;
   {$Else}
     Type
       PBuffer= ^TBuffer;
       TBUffer= packed array [0..16384] of TCharInfo;
     Var
       I: integer;
       dwCount: DWORD;
       WidthHeight,Coord: TCoord;
       hTempConsoleOutput: THandle;
       SecurityAttributes: TSecurityAttributes;
       Buffer: PBuffer;
       DestinationScreenRect,SourceScreenRect: TSmallRect;
   {$EndIf}
   Begin
     If dwSize>0 Then Begin
       {$IfDef OneByOne}
         LastX:=X;
         LastY:=Y;
         dwCount:=0;
         While dwCount < dwSize Do Begin
           WriteChrXY(LastX,LastY,Str[dwCount]);
           Inc(dwCount);
         End;
       {$Else}
         SecurityAttributes.nLength:=SizeOf(SecurityAttributes)-SizeOf(DWORD);
         SecurityAttributes.lpSecurityDescriptor:=NIL;
         SecurityAttributes.bInheritHandle:=TRUE;
         hTempConsoleOutput:=CreateConsoleScreenBuffer(
          GENERIC_READ OR GENERIC_WRITE,
          FILE_SHARE_READ OR FILE_SHARE_WRITE,
          @SecurityAttributes,
          CONSOLE_TEXTMODE_BUFFER,
          NIL
         );
         If dwSize<=(ConsoleScreenRect.Right-ConsoleScreenRect.Left+1) Then Begin
           WidthHeight.X:=dwSize;
           WidthHeight.Y:=1;
         End Else Begin
           WidthHeight.X:=ConsoleScreenRect.Right-ConsoleScreenRect.Left+1;
           WidthHeight.Y:=dwSize DIV WidthHeight.X;
           If (dwSize MOD WidthHeight.X) > 0 Then Inc(WidthHeight.Y);
         End;
         SetConsoleScreenBufferSize(hTempConsoleOutput,WidthHeight);
         DestinationScreenRect.Left:=0;
         DestinationScreenRect.Top:=0;
         DestinationScreenRect.Right:=WidthHeight.X-1;
         DestinationScreenRect.Bottom:=WidthHeight.Y-1;
         SetConsoleWindowInfo(hTempConsoleOutput,FALSE,DestinationScreenRect);
         Coord.X:=0;
         For I:=1 To WidthHeight.Y Do Begin
           Coord.Y:=I-0;
           FillConsoleOutputAttribute(hTempConsoleOutput,TextAttr,WidthHeight.X,Coord,dwCount);
           FillConsoleOutputCharacter(hTempConsoleOutput,' '     ,WidthHeight.X,Coord,dwCount);
         End;
         WriteConsole(hTempConsoleOutput,Str,dwSize,dwCount,NIL);
         {  }
         New(Buffer);
         Coord.X:= 0;
         Coord.Y:= 0;
         SourceScreenRect.Left:=0;
         SourceScreenRect.Top:=0;
         SourceScreenRect.Right:=WidthHeight.X-1;
         SourceScreenRect.Bottom:=WidthHeight.Y-1;
         ReadConsoleOutputA(hTempConsoleOutput,Buffer,WidthHeight,Coord,SourceScreenRect);
         Coord.X:=X-1;
         Coord.Y:=Y-1;
         DestinationScreenRect:=ConsoleScreenRect;
         WriteConsoleOutputA(hConsoleOutput,Buffer,WidthHeight,Coord,DestinationScreenRect);
         GotoXY((dwSize MOD WidthHeight.X)-1,WidthHeight.Y+1);
         Dispose(Buffer);
         {  }
         CloseHandle(hTempConsoleOutput);
       {$EndIf}
     End;
   End;
 *)

 procedure WriteStrXY(X, Y: Byte; Str: PChar; dwSize: Integer);
   {$IfDef OneByOne}
 var
   dwCount: integer;
   {$Else}
 var
   I: integer;
   LineSize, dwCharCount, dwCount, dwWait: DWORD;
   WidthHeight: TCoord;
   OneLine: packed array [0..131] of char;
   Line, TempStr: PChar;

   procedure NewLine;
   begin
     LastX := 1;
     Inc(LastY);
     if (LastY + ConsoleScreenRect.Top) > (ConsoleScreenRect.Bottom + 1) then
     begin
       Dec(LastY);
       GotoXY(1,1);
       DelLine;
     end;
     GotoXY(LastX, LastY);
   end;

   {$EndIf}
 begin
   if dwSize > 0 then
   begin
     {$IfDef OneByOne}
     LastX := X;
     LastY := Y;
     dwCount := 0;
     while dwCount < dwSize do
     begin
       WriteChrXY(LastX, LastY, Str[dwCount]);
       Inc(dwCount);
     end;
     {$Else}
     LastX := X;
     LastY := Y;
     GotoXY(LastX, LastY);
     dwWait  := dwSize;
     TempStr := Str;
     while (dwWait > 0) and (Pos(#13#10,StrPas(TempStr))= 1) do
     begin
       Dec(dwWait, 2);
       Inc(TempStr, 2);
       NewLine;
     end;
     while (dwWait > 0) and (Pos(#10, StrPas(TempStr)) = 1) do
     begin
       Dec(dwWait);
       Inc(TempStr);
       NewLine;
     end;
     if dwWait > 0 then
     begin
       if dwSize <= (ConsoleScreenRect.Right - ConsoleScreenRect.Left - LastX + 1) then
       begin
         WidthHeight.X := dwSize + LastX - 1;
         WidthHeight.Y := 1;
       end
       else
       begin
         WidthHeight.X := ConsoleScreenRect.Right - ConsoleScreenRect.Left + 1;
         WidthHeight.Y := dwSize div WidthHeight.X;
         if (dwSize mod WidthHeight.X) > 0 then Inc(WidthHeight.Y);
       end;
       for I := 1 to WidthHeight.Y do
       begin
         FillChar(OneLine, SizeOf(OneLine), #0);
         Line := @OneLine;
         LineSize := WidthHeight.X - LastX + 1;
         if LineSize > dwWait then LineSize := dwWait;
         Dec(dwWait, LineSize);
         StrLCopy(Line, TempStr, LineSize);
         Inc(TempStr, LineSize);
         dwCharCount := Pos(#13#10,StrPas(Line));
        if dwCharCount > 0 then
         begin
           OneLine[dwCharCount - 1] := #0;
           OneLine[dwCharCount]     := #0;
           WriteConsole(hConsoleOutput, Line, dwCharCount - 1,dwCount, nil);
           Inc(Line, dwCharCount + 1);
           NewLine;
           LineSize := LineSize - (dwCharCount + 1);
         end
         else
         begin
           dwCharCount := Pos(#10, StrPas(Line));
           if dwCharCount > 0 then
           begin
             OneLine[dwCharCount - 1] := #0;
             WriteConsole(hConsoleOutput, Line, dwCharCount - 1,dwCount, nil);
             Inc(Line, dwCharCount);
             NewLine;
             LineSize := LineSize - dwCharCount;
           end;
         end;
         if LineSize <> 0 then
         begin
           WriteConsole(hConsoleOutput, Line, LineSize, dwCount, nil);
         end;
         if dwWait > 0 then
         begin
           NewLine;
         end;
       end;
     end;
     {$EndIf}
   end;
 end;
 {  }
 {  Empty the buffer }
 {  }

 procedure FlushInputBuffer;
 begin
   FlushConsoleInputBuffer(hConsoleInput);
 end;
 {  }
 {  Get size of current cursor }
 {  }

 function GetCursor: Word;
 var
   CCI: TConsoleCursorInfo;
 begin
   GetConsoleCursorInfo(hConsoleOutput, CCI);
   GetCursor := CCI.dwSize;
 end;
 {  }
 {  Set size of current cursor }
 {  }

 procedure SetCursor(NewCursor: Word);
 var
   CCI: TConsoleCursorInfo;
 begin
   if NewCursor = $0000 then
   begin
     CCI.dwSize := GetCursor;
     CCI.bVisible := False;
   end
   else
   begin
     CCI.dwSize := NewCursor;
     CCI.bVisible := True;
   end;
   SetConsoleCursorInfo(hConsoleOutput, CCI);
 end;
 {  }
 { --- Begin of Interface functions & procedures of original CRT unit --- }

 procedure AssignCrt(var F: Text);
 begin
   Assign(F, '');
   TTextRec(F).OpenFunc := @OpenText;
 end;

 function KeyPressed: Boolean;
 var
   NumberOfEvents: DWORD;
   NumRead: DWORD;
   InputRec: TInputRecord;
   Pressed: boolean;
 begin
   Pressed := False;
   GetNumberOfConsoleInputEvents(hConsoleInput, NumberOfEvents);
   if NumberOfEvents > 0 then
   begin
     if PeekConsoleInput(hConsoleInput, InputRec, 1,NumRead) then
     begin
       if (InputRec.EventType = KEY_EVENT) and
         (InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.bKeyDown) then
       begin
         Pressed := True;
         {$IfDef MOUSE_IS_USED}
         MouseButtonPressed := False;
         {$EndIf}
       end
       else
       begin
         {$IfDef MOUSE_IS_USED}
         if (InputRec.EventType = _MOUSE_EVENT) then
         begin
           with InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.MouseEvent do
           begin
             MousePosX := dwMousePosition.X;
             MousePosY := dwMousePosition.Y;
             if dwButtonState = FROM_LEFT_1ST_BUTTON_PRESSED then
             begin
               MouseEventTime := Now;
               MouseButtonPressed := True;
               {If (dwEventFlags AND DOUBLE_CLICK)<>0 Then Begin}
               {End;}
             end;
           end;
         end;
         ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead);
         {$Else}
         ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead);
         {$EndIf}
       end;
     end;
   end;
   Result := Pressed;
 end;

 function ReadKey: char;
 var
   NumRead: DWORD;
   InputRec: TInputRecord;
 begin
   repeat
     repeat
     until KeyPressed;
     ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead);
   until InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.AsciiChar > #0;
   Result := InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.AsciiChar;
 end;

 procedure TextMode(Mode: Integer);
 begin
 end;

 procedure Window(X1, Y1, X2, Y2: Byte);
 begin
   ConsoleScreenRect.Left := X1 - 1;
   ConsoleScreenRect.Top := Y1 - 1;
   ConsoleScreenRect.Right := X2 - 1;
   ConsoleScreenRect.Bottom := Y2 - 1;
   WindMin := (ConsoleScreenRect.Top shl 8) or ConsoleScreenRect.Left;
   WindMax := (ConsoleScreenRect.Bottom shl 8) or ConsoleScreenRect.Right;
   {$IfDef WindowFrameToo}
   SetConsoleWindowInfo(hConsoleOutput, True, ConsoleScreenRect);
   {$EndIf}
   GotoXY(1,1);
 end;

 procedure GotoXY(X, Y: Byte);
 var
   Coord: TCoord;
 begin
   Coord.X := X - 1 + ConsoleScreenRect.Left;
   Coord.Y := Y - 1 + ConsoleScreenRect.Top;
   if not SetConsoleCursorPosition(hConsoleOutput, Coord) then
   begin
     GotoXY(1, 1);
     DelLine;
   end;
 end;

 function WhereX: Byte;
 var
   CBI: TConsoleScreenBufferInfo;
 begin
   GetConsoleScreenBufferInfo(hConsoleOutput, CBI);
   Result := TCoord(CBI.dwCursorPosition).X + 1 - ConsoleScreenRect.Left;
 end;

 function WhereY: Byte;
 var
   CBI: TConsoleScreenBufferInfo;
 begin
   GetConsoleScreenBufferInfo(hConsoleOutput, CBI);
   Result := TCoord(CBI.dwCursorPosition).Y + 1 - ConsoleScreenRect.Top;
 end;

 procedure ClrScr;
 begin
   FillerScreen(' ');
 end;

 procedure ClrEol;
 var
   Coord: TCoord;
   dwSize, dwCount: DWORD;
 begin
   Coord.X := WhereX - 1 + ConsoleScreenRect.Left;
   Coord.Y := WhereY - 1 + ConsoleScreenRect.Top;
   dwSize  := ConsoleScreenRect.Right - Coord.X + 1;
   FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
   FillConsoleOutputCharacter(hConsoleOutput, ' ', dwSize, Coord, dwCount);
 end;

 procedure InsLine;
 var
   SourceScreenRect: TSmallRect;
   Coord: TCoord;
   CI: TCharInfo;
   dwSize, dwCount: DWORD;
 begin
   SourceScreenRect := ConsoleScreenRect;
   SourceScreenRect.Top := WhereY - 1 + ConsoleScreenRect.Top;
   SourceScreenRect.Bottom := ConsoleScreenRect.Bottom - 1;
   CI.AsciiChar := ' ';
   CI.Attributes := TextAttr;
   Coord.X := SourceScreenRect.Left;
   Coord.Y := SourceScreenRect.Top + 1;
   dwSize := SourceScreenRect.Right - SourceScreenRect.Left + 1;
   ScrollConsoleScreenBuffer(hConsoleOutput, SourceScreenRect, nil, Coord, CI);
   Dec(Coord.Y);
   FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
 end;

 procedure DelLine;
 var
   SourceScreenRect: TSmallRect;
   Coord: TCoord;
   CI: TCharinfo;
   dwSize, dwCount: DWORD;
 begin
   SourceScreenRect := ConsoleScreenRect;
   SourceScreenRect.Top := WhereY + ConsoleScreenRect.Top;
   CI.AsciiChar := ' ';
   CI.Attributes := TextAttr;
   Coord.X := SourceScreenRect.Left;
   Coord.Y := SourceScreenRect.Top - 1;
   dwSize := SourceScreenRect.Right - SourceScreenRect.Left + 1;
   ScrollConsoleScreenBuffer(hConsoleOutput, SourceScreenRect, nil, Coord, CI);
   FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
 end;

 procedure TextColor(Color: Byte);
 begin
   LastMode := TextAttr;
   TextAttr := (Color and $0F) or (TextAttr and $F0);
   SetConsoleTextAttribute(hConsoleOutput, TextAttr);
 end;

 procedure TextBackground(Color: Byte);
 begin
   LastMode := TextAttr;
   TextAttr := (Color shl 4) or (TextAttr and $0F);
   SetConsoleTextAttribute(hConsoleOutput, TextAttr);
 end;

 procedure LowVideo;
 begin
   LastMode := TextAttr;
   TextAttr := TextAttr and $F7;
   SetConsoleTextAttribute(hConsoleOutput, TextAttr);
 end;

 procedure HighVideo;
 begin
   LastMode := TextAttr;
   TextAttr := TextAttr or $08;
   SetConsoleTextAttribute(hConsoleOutput, TextAttr);
 end;

 procedure NormVideo;
 begin
   LastMode := TextAttr;
   TextAttr := StartAttr;
   SetConsoleTextAttribute(hConsoleOutput, TextAttr);
 end;

 procedure Delay(MS: Word);
   { 
  Const 
    Magic= $80000000; 
  var 
   StartMS,CurMS,DeltaMS: DWORD; 
   }
 begin
   Windows.SleepEx(MS, False);  // Windows.Sleep(MS); 
    { 
    StartMS:= GetTickCount; 
    Repeat 
      CurMS:= GetTickCount; 
      If CurMS >= StartMS Then 
         DeltaMS:= CurMS - StartMS 
      Else DeltaMS := (CurMS + Magic) - (StartMS - Magic); 
    Until MS<DeltaMS; 
    }
 end;

 procedure Sound(Hz: Word);
 begin
   {SetSoundIOPermissionMap(LocalIOPermission_ON);}
   SoundFrequency := Hz;
   if IsWinNT then
   begin
     Windows.Beep(SoundFrequency, SoundDuration)
   end
   else
   begin
     asm
         mov  BX,Hz
         cmp  BX,0
         jz   @2
         mov  AX,$34DD
         mov  DX,$0012
         cmp  DX,BX
         jnb  @2
         div  BX
         mov  BX,AX
         { Sound is On ? }
         in   Al,$61
         test Al,$03
         jnz  @1
         { Set Sound On }
         or   Al,03
         out  $61,Al
         { Timer Command }
         mov  Al,$B6
         out  $43,Al
         { Set Frequency }
     @1: mov  Al,Bl
         out  $42,Al
         mov  Al,Bh
         out  $42,Al
     @2:
     end;
   end;
 end;

 procedure NoSound;
 begin
   if IsWinNT then
   begin
     Windows.Beep(SoundFrequency, 0);
   end
   else
   begin
       asm
         { Set Sound On }
         in   Al,$61
         and  Al,$FC
         out  $61,Al
       end;
   end;
   {SetSoundIOPermissionMap(LocalIOPermission_OFF);}
 end;
 { --- End of Interface functions & procedures of original CRT unit --- }
 {  }

 procedure OverwriteChrXY(X, Y: Byte; Chr: char);
 var
   Coord: TCoord;
   dwSize, dwCount: DWORD;
 begin
   LastX := X;
   LastY := Y;
   Coord.X := LastX - 1 + ConsoleScreenRect.Left;
   Coord.Y := LastY - 1 + ConsoleScreenRect.Top;
   dwSize := 1;
   FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
   FillConsoleOutputCharacter(hConsoleOutput, Chr, dwSize, Coord, dwCount);
   GotoXY(LastX, LastY);
 end;

 {  --------------------------------------------------  }
 {  Console Event Handler }
 {  }
 {$IfDef CRT_EVENT}
 function ConsoleEventProc(CtrlType: DWORD): Bool; stdcall; far;
 var
   S: {$IfDef Win32}ShortString{$Else}String{$EndIf};
   Message: PChar;
 begin
   case CtrlType of
     CTRL_C_EVENT: S        := 'CTRL_C_EVENT';
     CTRL_BREAK_EVENT: S    := 'CTRL_BREAK_EVENT';
     CTRL_CLOSE_EVENT: S    := 'CTRL_CLOSE_EVENT';
     CTRL_LOGOFF_EVENT: S   := 'CTRL_LOGOFF_EVENT';
     CTRL_SHUTDOWN_EVENT: S := 'CTRL_SHUTDOWN_EVENT';
     else
       S := 'UNKNOWN_EVENT';
   end;
   S := S + ' detected, but not handled.';
   Message := @S;
   Inc(Message);
   MessageBox(0, Message, 'Win32 Console', MB_OK);
   Result := True;
 end;
   {$EndIf}

 function MouseReset: Boolean;
 begin
   MouseColWidth := 1;
   MouseRowWidth := 1;
   Result := True;
 end;

 procedure MouseShowCursor;
 const
   ShowMouseConsoleMode = ENABLE_MOUSE_INPUT;
 var
   cMode: DWORD;
 begin
   GetConsoleMode(hConsoleInput, cMode);
   if (cMode and ShowMouseConsoleMode) <> ShowMouseConsoleMode then
   begin
     cMode := cMode or ShowMouseConsoleMode;
     SetConsoleMode(hConsoleInput, cMode);
   end;
 end;

 procedure MouseHideCursor;
 const
   ShowMouseConsoleMode = ENABLE_MOUSE_INPUT;
 var
   cMode: DWORD;
 begin
   GetConsoleMode(hConsoleInput, cMode);
   if (cMode and ShowMouseConsoleMode) = ShowMouseConsoleMode then
   begin
     cMode := cMode and ($FFFFFFFF xor ShowMouseConsoleMode);
     SetConsoleMode(hConsoleInput, cMode);
   end;
 end;

 function MouseKeyPressed: Boolean;
   {$IfDef MOUSE_IS_USED}
 const
   MouseDeltaTime = 200;
 var
   ActualTime: TDateTime;
   HourA, HourM, MinA, MinM, SecA, SecM, MSecA, MSecM: word;
   MSecTimeA, MSecTimeM: longInt;
   MSecDelta: longInt;
   {$EndIf}
 begin
   MousePressedButtons := 0;
   {$IfDef MOUSE_IS_USED}
   Result := False;
   if MouseButtonPressed then
   begin
     ActualTime := NOW;
     DecodeTime(ActualTime, HourA, MinA, SecA, MSecA);
     DecodeTime(MouseEventTime, HourM, MinM, SecM, MSecM);
     MSecTimeA := (3600 * HourA + 60 * MinA + SecA) * 100 + MSecA;
     MSecTimeM := (3600 * HourM + 60 * MinM + SecM) * 100 + MSecM;
     MSecDelta := Abs(MSecTimeM - MSecTimeA);
     if (MSecDelta < MouseDeltaTime) or (MSecDelta > (8784000 - MouseDeltaTime)) then
     begin
       MousePressedButtons := MouseLeftButton;
       MouseButtonPressed := False;
       Result := True;
     end;
   end;
   {$Else}
   Result := False;
   {$EndIf}
 end;

 procedure MouseGotoXY(X, Y: Integer);
 begin
   {$IfDef MOUSE_IS_USED}
   mouse_event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MOVE,
     X - 1,Y - 1,WHEEL_DELTA, GetMessageExtraInfo());
   MousePosY := (Y - 1) * MouseRowWidth;
   MousePosX := (X - 1) * MouseColWidth;
   {$EndIf}
 end;

 function MouseWhereY: Integer;
   {$IfDef MOUSE_IS_USED}
     {Var 
      lppt, lpptBuf: TMouseMovePoint;}
   {$EndIf}
 begin
   {$IfDef MOUSE_IS_USED}
       {GetMouseMovePoints( 
        SizeOf(TMouseMovePoint), lppt, lpptBuf, 
        7,GMMP_USE_DRIVER_POINTS 
      ); 
      Result:=lpptBuf.Y DIV MouseRowWidth;}
   Result := (MousePosY div MouseRowWidth) + 1;
   {$Else}
   Result := -1;
   {$EndIf}
 end;

 function MouseWhereX: Integer;
   {$IfDef MOUSE_IS_USED}
     {Var 
      lppt, lpptBuf: TMouseMovePoint;}
   {$EndIf}
 begin
   {$IfDef MOUSE_IS_USED}
       {GetMouseMovePoints( 
        SizeOf(TMouseMovePoint), lppt, lpptBuf, 
        7,GMMP_USE_DRIVER_POINTS 
      ); 
      Result:=lpptBuf.X DIV MouseColWidth;}
   Result := (MousePosX div MouseColWidth) + 1;
   {$Else}
   Result := -1;
   {$EndIf}
 end;
   {  }

 procedure Init;
 const
   ExtInpConsoleMode = ENABLE_WINDOW_INPUT or ENABLE_PROCESSED_INPUT or ENABLE_MOUSE_INPUT;
   ExtOutConsoleMode = ENABLE_PROCESSED_OUTPUT or ENABLE_WRAP_AT_EOL_OUTPUT;
 var
   cMode: DWORD;
   Coord: TCoord;
   OSVersion: TOSVersionInfo;
   CBI: TConsoleScreenBufferInfo;
 begin
   OSVersion.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
   GetVersionEx(OSVersion);
   if OSVersion.dwPlatformId = VER_PLATFORM_WIN32_NT then
     IsWinNT := True
   else
     IsWinNT := False;
   PtrOpenText := TTextRec(Output).OpenFunc;
   {$IfDef HARD_CRT}
   AllocConsole;
   Reset(Input);
   hConsoleInput := GetStdHandle(STD_INPUT_HANDLE);
   TTextRec(Input).Handle := hConsoleInput;
   ReWrite(Output);
   hConsoleOutput := GetStdHandle(STD_OUTPUT_HANDLE);
   TTextRec(Output).Handle := hConsoleOutput;
   {$Else}
   Reset(Input);
   hConsoleInput := TTextRec(Input).Handle;
   ReWrite(Output);
   hConsoleOutput := TTextRec(Output).Handle;
   {$EndIf}
   GetConsoleMode(hConsoleInput, cMode);
   if (cMode and ExtInpConsoleMode) <> ExtInpConsoleMode then
   begin
     cMode := cMode or ExtInpConsoleMode;
     SetConsoleMode(hConsoleInput, cMode);
   end;

   TTextRec(Output).InOutFunc := @TextOut;
   TTextRec(Output).FlushFunc := @TextOut;
   GetConsoleScreenBufferInfo(hConsoleOutput, CBI);
   GetConsoleMode(hConsoleOutput, cMode);
   if (cMode and ExtOutConsoleMode) <> ExtOutConsoleMode then
   begin
     cMode := cMode or ExtOutConsoleMode;
     SetConsoleMode(hConsoleOutput, cMode);
   end;
   TextAttr  := CBI.wAttributes;
   StartAttr := CBI.wAttributes;
   LastMode  := CBI.wAttributes;

   Coord.X := CBI.srWindow.Left;
   Coord.Y := CBI.srWindow.Top;
   WindMin := (Coord.Y shl 8) or Coord.X;
   Coord.X := CBI.srWindow.Right;
   Coord.Y := CBI.srWindow.Bottom;
   WindMax := (Coord.Y shl 8) or Coord.X;
   ConsoleScreenRect := CBI.srWindow;

   SoundDuration := -1;
   OldCp := GetConsoleOutputCP;
   SetConsoleOutputCP(1250);
   {$IfDef CRT_EVENT}
   SetConsoleCtrlHandler(@ConsoleEventProc, True);
   {$EndIf}
   {$IfDef MOUSE_IS_USED}
   SetCapture(hConsoleInput);
   KeyPressed;
   {$EndIf}
   MouseInstalled := MouseReset;
   Window(1,1,80,25);
   ClrScr;
 end;

 {  }

 procedure Done;
 begin
   {$IfDef CRT_EVENT}
   SetConsoleCtrlHandler(@ConsoleEventProc, False);
   {$EndIf}
   SetConsoleOutputCP(OldCP);
   TextAttr := StartAttr;
   SetConsoleTextAttribute(hConsoleOutput, TextAttr);
   ClrScr;
   FlushInputBuffer;
   {$IfDef HARD_CRT}
   TTextRec(Input).Mode := fmClosed;
   TTextRec(Output).Mode := fmClosed;
   FreeConsole;
   {$Else}
   Close(Input);
   Close(Output);
   {$EndIf}
 end;

 initialization
   Init;

 finalization
   Done;
   {$Endif win32}
 end.