CRT для консольного приложения

=== CRT для консольного приложения ===
$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.
Source: Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 02194